home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol049 / rbbspc.bas < prev    next >
Encoding:
BASIC Source File  |  1987-01-11  |  67.3 KB  |  1,249 lines
  1. 1 ' WARNING !!! DO NOT CHANGE, BYPASS OR REMOVE LINES 25-44
  2. 2 ' RBBS-PC.BAS (RBBS-PC ver. CPC11)
  3. 3 REM $LINESIZE: 132
  4. 4 'by D. Thomas Mack
  5. 5 '   The Second Ring
  6. 6 '   10210 Oxfordshire Road
  7. 7 '   Great Falls, Virginia 22066
  8. 8 '
  9. 9 ' *******************************NOTICE*************************************
  10. 10 ' *  A limited license is granted to all users of this program and it's   *
  11. 11 ' *  companion program, CONFIG.BAS (ver. CPC11), to make copies of this   *
  12. 12 ' *  program and distribute the copies to other users, on the following   *
  13. 13 ' *  conditions:                                                          *
  14. 14 ' *    1.   The notices contained in lines 25 through 44 of the programs  *
  15. 15 ' *         are not altered, bypassed, or removed.                        *
  16. 16 ' *    2.   The program is not to be disrtibuted to others in modified    *
  17. 17 ' *         form (i.e. the line numbers must remain the same).            *
  18. 18 ' *    3.   No fee is to be charged (or any other consideration received) *
  19. 19 ' *         for coping or distributing these programs without an express  *
  20. 20 ' *         written agreement with D. Thomas Mack, The Second Ring, 10210 *
  21. 21 ' *         Oxfordshire Road, Great falls, Virginia 22006                 *
  22. 22 ' *                                                                       *
  23. 23 ' *   Copyright (c) 1983 D. Thomas Mack, The Second Ring                  *
  24. 24 ' *************************************************************************
  25. 25 SCREEN 0,1,0:WIDTH 80:CLS:KEY OFF:LOCATE ,,0
  26. 26 PRINT TAB(60)"tm":PRINT TAB(16) STRING$(15,205)" U S E R W A R E "STRING$(15,205)
  27. 27 PRINT:PRINT TAB(17)"Capital PC User Group User-Supported Software":PRINT:PRINT TAB(7) CHR$(214)STRING$(62,196)CHR$(183)
  28. 28 FOR I=1 TO 12:READ A$:PRINT TAB(7) CHR$(186);A$;SPACE$(62-LEN(A$));CHR$(186):NEXT
  29. 29 PRINT TAB(7) CHR$(211)STRING$(62,196)CHR$(189):PRINT TAB(27)"Copyright (c) 1983 Tom Mack, 10210 Oxfordshire Rd., Great Falls, Virginia  22066
  30. 30 DATA"    If you are using RBBS-PC CPC11.2 and find it of value,
  31. 31 DATA"    would like to suggest you consider a $6 contribution to
  32. 32 DATA"
  33. 33 DATA"                 Capital PC Software Exchange
  34. 34 DATA"                     Post Office Box 6128
  35. 35 DATA"                Silver Spring, Maryland  20906
  36. 36 DATA"
  37. 37 DATA"    Feel free to copy and share RBBS-PC CPC11 with other
  38. 38 DATA"    users on these three conditions:
  39. 39 DATA"    1.  RBBS-PC CPC11 is not distributed in modified form.
  40. 40 DATA"    2.  No fee or consideration is charged.
  41. 41 DATA"    3.  This notice is not bypassed or removed.
  42. 42 DEF FNTX!=CSNG(FIX((VAL(MID$(TIME$,1,2))*60*60)+(VAL(MID$(TIME$,4,2))*60)+(VAL(MID$(TIME$,7,2))*1))) ' CPC10
  43. 43 IWAIT!=FNTX!+10
  44. 44 IF FNTX!<IWAIT! THEN GOTO 44
  45. 45 ' ***********************************************************************
  46. 46 '
  47. 47 'RBBS-PC.BAS   Remote Bulletin Board Program  CPC11
  48. 48 'Capital PC RBBS-PC enhancement version CPC11:
  49. 49 '
  50. 50 '   CPC00 Original author - Russ Lane         6/21/82 - Copyright (c) 1982
  51. 51 '   CPC01 Revised by Brad Hanson              3->5/83 - Copyright (c) 1983
  52. 52 '   CPC01 2,3,5,6,7 Revised by Larry Jordan   4->5/83 - Copyright (c) 1983
  53. 53 '   CPC03 04 & 05 Revised by Gary Horwith        5/83 - Copyright (c) 1983
  54. 54 '   CPC04 Revised by Rich Schinnell              5/83 - Copyright (c) 1983
  55. 55 '   CPC01 Revised by Jim Fry                     5/83 - Copyright (c) 1983
  56. 56 '   CPC09 4,7  Revised by Scott Loftesness    5->6/83 - Copyright (c) 1983
  57. 57 '   CPC10 Tom Mack Revised & made compilable  6->8/83 - Copyright (c) 1983
  58. 58 '   CPC11 Tom Mack added RBBS-PC.DEF file use    8/83 - Copyright (c) 1983
  59. 87 '  For Hayes Smartmodem 300 or 1200 .. Switch settings UUDDDUUD
  60. 88 '                                                      12345678
  61. 89 ' ***********************************************************************
  62. 90 CLOSE
  63. 94 CLEAR
  64. 95 WIDTH 80:SCREEN 0,0,0:KEY OFF:SYSOPNEXT=0:PAUSE$=CHR$(19):BELL$=CHR$(7):BK2$=CHR$(8):XOFF$=CHR$(19):XON$=CHR$(17):CLS
  65. 102 DEF FNTI!=CSNG(FIX((VAL(MID$(TIME$,1,2))*60*60)+(VAL(MID$(TIME$,4,2))*60)+(VAL(MID$(TIME$,7,2))*1))) ' CPC10
  66. 103 A!=FRE("A"):TI$=TIME$ 'Set dummy time for recycle
  67. 104 ON ERROR GOTO 13000:DEF SEG
  68. 105 ON KEY(1) GOSUB 31000:KEY(1) ON 'CPC01 KEY 1 - Return to System
  69. 106 ON KEY(2) GOSUB 32000:KEY(2) ON 'CPC01 KEY 2 - Exit program into BASIC
  70. 107 ON KEY(3) GOSUB 33000:KEY(3) ON 'CPC01 KEY 3 - Toggle Line Printer - SJL
  71. 108 ON KEY(4) GOSUB 33040:KEY(4) ON 'CPC03 KEY 4 - Toggle SYSOP page on/off
  72. 109 ON KEY(5) GOSUB 14000:KEY(5) ON
  73. 110 'ON KEY(6)
  74. 111 ON KEY(7) GOSUB 15000:KEY(7) ON ' KEY 7 - Hold system for SYSOP next
  75. 112 'ON KEY(8)
  76. 113 ON KEY(9) GOSUB 39000:KEY(9) ON 'CPC01 KEY 9 - Toggle Snoop On/Off
  77. 114 ON KEY(10) GOSUB 30000:KEY(10) ON 'CPC01 KEY 10 - Forced chat mode
  78. 115 DEFINT A-Z:CR$=CHR$(13):LF$=CHR$(10):ABT$=CHR$(11):PL=23
  79. 116 VERSION$="CPC11.2C (compilable)"
  80. 117 CONFIG$="RBBS-PC.DEF"
  81. 118 OPEN "I",#1,CONFIG$
  82. 119 INPUT #1,FDEV$,RDEV$,PASS1$,PASS2$,NFIR$,NLAS$,CBACK,ANNOY.ON,ANNOY.OFF,TIME.MAX!,MESSAGE.MAX,LAPSE.MAX,LPRT,XPR,BULL,BELL,PRT,COMPILED
  83. 120 INPUT #1,MESSAGES$,MESSAGES.BAK$,CALLERS$,COMMENTS$,USERS$,LONGCALR$,R$,WELCOME$,NEWUSER$,DIR$
  84. 121 INPUT #1,HELP01$,HELP02$,HELP03$,HELP04$,HELP05$,HELP06$,HELP07$,BULLETIN$,BULLET1$,BULLET2$,BULLET3$,BULLET4$,BULLET5$,BULLET6$
  85. 122 CLOSE #1
  86. 123 FOR I=1 TO 10:KEY I,"":NEXT I:LOCATE ,,1 'CPC01
  87. 124 IF COMPILED THEN MID$(VERSION$,10)="--(compiled)"
  88. 125 BK$=CHR$(8)+CHR$(32)+CHR$(8):BK1$=CHR$(29)+CHR$(32)+CHR$(29)
  89. 126 CP$="COM1"
  90. 127 TIME.MAX!=TIME.MAX!*60:MARGIN=72:ERR.COUNT=0:ERR.MAX=10:TIME.OUT!=3*60:TSCRN.MAX=120 'CPC08
  91. 128 MESSAGES$=RDEV$+MESSAGES$:CALLERS$=RDEV$+CALLERS$:USERS$=RDEV$+USERS$:LONGCALR$=RDEV$+LONGCALR$:COMMENTS$=RDEV$+COMMENTS$:MESSAGES.BAK$=RDEV$+MESSAGES.BAK$ 'CPC04
  92. 129 IF CP$="COM2" THEN LSB=&H2F8:MSB=&H2F9:LCR=&H2FB:LSR=&H2FD:MSR=&H2FE ELSE LSB=&H3F8:MSB=&H3F9:LCR=&H3FB:LSR=&H3FD:MSR=&H3FE
  93. 130 DIM M(250,2),A$(30),B$(10),C$(30),FLS$(128):GOSUB 135:GOTO 175 'M(Record#,Msg#) 'CPC05
  94. 135 'Write Record #, Msg #, to Array -------------
  95. 140 CLOSE #1,2:LASTR=0:R=2:OPEN "R",#1,MESSAGES$:FIELD #1,128 AS R$
  96. 145 IF LOF(1)=0 THEN LSET R$="     1  -1 0":PUT 1 ELSE GET 1
  97. 147 LASTM=VAL(LEFT$(R$,8)):AVAILABLE=VAL(MID$(R$,9,2))
  98. 150 GET 1,R:IF MID$(R$,116,1)=CHR$(226) THEN DEAD=-1 ' If it's killed...
  99. 155 RR=VAL(MID$(R$,118)):IF DEAD THEN 165 ELSE IF RR<1 THEN RR=1:IF EOF(1) THEN 170
  100. 160 LASTR=LASTR+1:M(LASTR,1)=R:M(LASTR,2)=VAL(MID$(R$,2,4))
  101. 165 R=R+RR:DEAD=0:GOTO 150
  102. 170 FIRSTM=M(1,2):RETURN
  103. 175 SOH$=CHR$(1):EOT$=CHR$(4):ACK$=CHR$(6):NAK$=CHR$(21):CAN$=CHR$(24):ESC$=CHR$(27):STP$=CHR$(0)+CHR$(112)
  104. 180 BPS=&H180:NBPS=&H100:FALSE=0:TRUE=NOT FALSE
  105. 181 AVAILABLE=TRUE 'change to false to turn default operator page off
  106. 182 BIT.8=FALSE:ONLINE=FALSE:ANNOY=TRUE  'CPC01 change to PRT=FALSE to leave snoop OFF.  ANNOY.ON must be < ANNOY.OFF. Use 24 hr clock with no ':'
  107. 183 PRINT "RBBS-PC Version ";VERSION$:PRINT "Free memory: ";FRE("A") 'CPC07
  108. 187 IF LPRT THEN GOSUB 480:LPRINT :LPRINT :LPRINT "RBBS-PC Version ";VERSION$;" up at " TIM$ " on " DATE$:GOSUB 50500 'CPC08
  109. 189 PRINT:PRINT "Enter:":PRINT "       <ESC> for sysop sign-on maintenance/page.":PRINT "       <F1>  to return to DOS.":PRINT "       <F2>  to return to BASIC." 'CPC01
  110. 191 PRINT "       <F3>  to toggle Line Printer on/off.":PRINT "       <F4>  to toggle SYSOP Page Bell on/off." 'CPC03
  111. 193 PRINT "       <F5>  to force on-line state.":PRINT "       <F6>  Unassigned."
  112. 194 PRINT "       <F7>  SYSOP gets system after this caller":PRINT "       <F8>  Unassigned."
  113. 195 PRINT "       <F9>  to toggle SNOOP on/off.":PRINT "       <F10> to force CHAT and <ESC> to end." 'CPC03
  114. 200 'Wait for Caller to Call ---------------------
  115. 210 OPEN CP$+":1200,E,7,1,RS,CD,DS" AS #3:PRINT #3,"ATZ":FOR X=1 TO 3:PRINT #3,CR$;:SOUND 32767,18:NEXT
  116. 215 'CPC06
  117. 220 PRINT #3,"ATQ1 S4=13 S5=130 S10=20 S0=255 S1?":INPUT #3,X$
  118. 225 GOSUB 480
  119. 230 PRINT:PRINT "RBBS-PC is ready for calls at " TIM$ " on " DATE$ 'CPC09
  120. 231 PRINT:PRINT"<< Screen will clear after time delay to prevent burn-in of display. >>":PRINT:IF NOT PRT THEN LOCATE ,,0
  121. 235 TSCRN!=FNTI! 'CPC10
  122. 239 RB=2:IF CBACK>0 THEN RB=2400:COLOR 7,0,4:ELSE COLOR 7,0,0
  123. 240 X=1:WHILE (INP(MSR) AND &H40)=0
  124. 250 X$=INKEY$:IF X$=CHR$(27) THEN LOCATE 24,1:PRINT "Sysop is in.":TI!=FNTI!:GOSUB 14500:LOCAL=-1:GOTO 470 ELSE IF X$=STP$ THEN SYSTEM
  125. 260 IF RB THEN RB=RB-1:IF (RB=0 AND PRT AND CBACK<>0) THEN PRINT "Ringback timeout" 'CPC09
  126. 265 MMM!=FNTI!-TSCRN!:IF MMM!>TSCRN.MAX THEN LOCATE ,,0:CLS:TSCRN!=FNTI!
  127. 270 WEND:IF CBACK=0 THEN 320 'CPC02
  128. 275 WHILE (INP(MSR) AND &H40)
  129. 276 IF PRT THEN SOUND 3000,1:SOUND 4000,2:SOUND 32767,6
  130. 277 WEND:IF LOC(3) THEN X$=INPUT$(LOC(3),3) 'CPC02
  131. 280 PRINT #3,"ATS1?"
  132. 290 INPUT #3,X$:IF LEN(X$)=0 THEN 290 ELSE IF PRT THEN PRINT "Ring ";X$ 'CPC01
  133. 300 IF RB AND (VAL(X$)<=X) AND (VAL(X$)<>0) THEN 320 ELSE X=VAL(X$)
  134. 310 IF X<CBACK THEN 239
  135. 320 CLOSE 3:OPEN CP$+":300,E,7,1,RS,CD,DS" AS #3:PRINT #3,"ATQ1E0S0=0A":CLOSE #3
  136. 325 OPEN CP$+":300,N,8,1,CD,DS,CS" AS 3
  137. 330 Q=&H180:QQ=&H60:IF PRT THEN LOCATE ,,1 'CPC09
  138. 331 FOR JJ=1 TO 600:SOUND 32767,1:IF INP(MSR)>127 THEN 333
  139. 332 NEXT JJ:RUN 90 'CPC01
  140. 333 GOSUB 21280:GOSUB 50500:OUT LCR,&H3:BIT.8=TRUE
  141. 335 IF INP(MSR)<128 THEN 13540 ELSE IF EOF(3) THEN 335
  142. 340 A=0:A=ASC(INPUT$(LOC(3),3)):IF A=13 THEN GOTO 350 ELSE IF A=141 THEN OUT LCR,&H1A:BIT.8=FALSE:GOTO 350
  143. 345 SWAP Q,QQ:GOSUB 1654:OUT LCR,&H3:BIT.8=TRUE:GOTO 335
  144. 350 I=0:GOSUB 480:IF Q=&H60 THEN BPS=TRUE ELSE BPS=FALSE
  145. 355 TI!=FNTI!:IF TI!>CTI! THEN GOSUB 42000:ONLINE=TRUE:GOSUB 21280
  146. 360 LF=-1:UC=0:PRINT #3,LF$:PRINT #3,"CAN YOUR TERMINAL DISPLAY LOWER CASE";:GOSUB 1500:Z$=B$(1):GOSUB 5000:PRINT #3,"" 'CPC01
  147. 364 IF BIT.8 THEN PARMS$="NO PARITY, 8 DATA BITS, 1 STOP BIT." ELSE PARMS$="EVEN PARITY, 7 DATA BITS, 1 STOP BIT." 'CPC04
  148. 365 IF BPS THEN BAUD$="1200 BAUD, " ELSE BAUD$="300 BAUD, " 'CPC03
  149. 366 A$="RBBS-PC VERSION "+VERSION$:GOSUB 1400:A$=LF$+"OPERATING AT "+BAUD$+PARMS$ 'CPC04
  150. 367 CR=2:GOSUB 1400 'CPC03
  151. 370 IF NO THEN UC=-1 ELSE IF NOT YES THEN 360
  152. 380 CR=0:STI=-1:FILE$=WELCOME$:GOSUB 6000 'STI Enables Interrupts (Ctrl-K) 'CPC01
  153. 395 CR=2:STI=0:GOSUB 1400:TRIES=0
  154. 400 'Get Caller's Name ---------------------------
  155. 405 IF TRIES>5 THEN RUN 90
  156. 410 TRIES=TRIES+1:GOSUB 1400:A$="What is your FIRST Name":GOSUB 1500
  157. 415 IF Q=0 THEN 400 ELSE Z$=B$(1):GOSUB 5000:FIRST$=Z$:IF Q=1 THEN 425
  158. 420 Z$=B$(2):GOTO 430
  159. 425 A$="     And your LAST Name":GOSUB 1500:Z$=B$(1)
  160. 430 GOSUB 5000:LAST$=Z$
  161. 435 IF LEN(FIRST$)<2 OR LEN(LAST$)<2 THEN 400
  162. 440 IF FIRST$=PASS1$ AND LAST$=PASS2$ THEN 470 'CPC08
  163. 445 NAM$=MID$(FIRST$+" "+LAST$,1,31)
  164. 450 IF INSTR(NAM$,"SYSOP")OR INSTR(NAM$,NFIR$+" "+NLAS$)THEN 10620'Logoff jerks
  165. 455 FOR J=1 TO LEN(NAM$)
  166. 460 X=ASC(MID$(NAM$,J,1)):IF (X<65 OR X>90) AND (X<>32 AND X<>39 AND X<>45 AND X<>46) THEN 400
  167. 465 NEXT:GOTO 500
  168. 469 'CPC08
  169. 470 FIRST$=NFIR$:LAST$=NLAS$:NAM$="SYSOP":SYSOP=-1:PRT=TRUE:MARGIN=72:GOSUB 480:IF LOCAL THEN 850 ELSE GOTO 835 'CPC08
  170. 480 TI$=TIME$:D$=LEFT$(DATE$,6)+RIGHT$(DATE$,2)
  171. 482 TIM$=TIME$:IF VAL(LEFT$(TIM$,2))>12 THEN MID$(TIM$,1,2)=RIGHT$(STR$(VAL(LEFT$(TIM$,2))-12),2):TIM$=LEFT$(TIM$,5)+" PM":RETURN ELSE TIM$=LEFT$(TIM$,5)+" AM":RETURN 'CPC08
  172. 500 'Check Last Caller ---------------------------
  173. 505 'CPC04
  174. 510 A$="Checking User File...":CR=2:GOSUB 1400
  175. 520 GET 1,1:IF NAM$<>MID$(R$,21,LEN(NAM$)) THEN 600
  176. 540 LASTCALR=-1:A$="Welcome back, "+FIRST$+".":GOSUB 1400 'CPC01
  177. 600 'Check User File -----------------------------
  178. 610 GOSUB 9400:X$=NAM$+SPACE$(31-LEN(NAM$)):UIX#=0
  179. 615 GET 2:IF EOF(2) THEN 700 ELSE IF ASC(N$)=0 THEN UIX#=LOC(2):GOTO 615
  180. 620 IF X$<>N$ THEN 615 ELSE IF ST$<>"Y" THEN 10640 ELSE UIX#=LOC(2)
  181. 625 I=0:IF Q=3 THEN Z$=B$(3):GOTO 635
  182. 630 GOSUB 1400:A$="Password (dots will echo) ":SECURE=-1:GOSUB 1500:SECURE=NOT SECURE:Z$=B$(1) 'CPC03
  183. 635 IF LEN(Z$)>15 THEN 630 ELSE GOSUB 5000:Z$=Z$+SPACE$(15-LEN(Z$))
  184. 640 IF Z$<>PW$ THEN I=I+1:IF I<4 THEN 630 ELSE RUN 90
  185. 645 NEWCALR=0:GOTO 800
  186. 700 'Get New User's Background -------------------
  187. 705 NEWCALR=-1:IF UIX# THEN GET 2,UIX# ELSE UIX#=LOC(2)
  188. 710 A$="What type of system are you calling from":GOSUB 1500:IF Q=0 THEN 400 ELSE LSET MA$=B$(1)
  189. 715 A$="What CITY and STATE are you calling from":GOSUB 1500
  190. 720 IF Q=0 THEN 400 ELSE Z$=B$(1):GOSUB 5000
  191. 735 A$=NAM$+" from "+Z$:GOSUB 1400
  192. 745 A$="Is this correct":GOSUB 1500:GOSUB 1400:IF NOT YES THEN 400 ELSE LSET CS$=Z$
  193. 750 A$="Type in a message security PASSWORD (not IBMPC) ":GOSUB 1500:IF Q=0 THEN 750 ELSE IF LEN(B$(1))>15 THEN A$="15 Char. max":GOSUB 1400:GOTO 750 ELSE Z$=B$(1):GOSUB 5000 'CPC01
  194. 755 A$="Type in PASSWORD again for security double check":SECURE=-1:GOSUB 1500:SECURE=0:GOSUB 1400:SWAP Z$,B$(1):GOSUB 5000:IF B$(1)<>Z$ THEN A$="Passwords don't match, start over !":GOSUB 1400:GOTO 750 'CPC03
  195. 760 GOSUB 5000:LSET PW$=Z$:GOSUB 1400:A$=FIRST$+", please remember your password for the next time you call.":CR=2:GOSUB 1400:LSET N$=NAM$:LSET ST$="Y" 'CPC08
  196. 765 LSET N$=NAM$:LSET ST$="Y":LSET OP$=MKI$(0)+MKI$(0)+MKI$(-1)+MKI$(64)+STRING$(4,0)+CHR$(PL)+STRING$(2,0)
  197. 770 'CPC08
  198. 800 'Log To Disk ---------------------------------
  199. 805 GOSUB 1400:A$="Logging "+NAM$+" to disk...":GOSUB 1400 'CPC04
  200. 810 TIMON=CVI(MID$(OP$,1,2))+1:LMSG=CVI(MID$(OP$,3,2)):LF=CVI(MID$(OP$,5,2)):MARGIN=CVI(MID$(OP$,7,2)):BELL=CVI(MID$(OP$,9,2)):XPR=CVI(MID$(OP$,11,2)):PL=ASC(MID$(OP$,13))
  201. 812 IF LMSG>LASTM THEN LMSG=0
  202. 815 LSET OP$=MKI$(TIMON)+MID$(OP$,3):LSET TD$=D$+" "+TI$:PUT 2,UIX#
  203. 820 IF NOT NEWCALR THEN A$="You have signed on"+STR$(TIMON)+" times.":CR=2:GOSUB 1400 'CPC04
  204. 835 CLOSE 2:OPEN "A",2,CALLERS$
  205. 836 IF BIT.8 THEN PARMS$="N,8,1" ELSE PARMS$="E,7,1"
  206. 837 Z$=NAM$+" on at "+D$+", "+TIM$+" -- "+BAUD$+PARMS$ 'CPC04
  207. 840 PRINT #2,Z$:CLOSE 2
  208. 841 IF LPRT THEN LPRINT "  "+Z$
  209. 845 IF LASTCALR THEN 945 ' Bypass Search For Msgs CPC06
  210. 850 GOSUB 950:IF BULL<1 THEN A$="Sorry, "+FIRST$+" there are no system bulletins today.":GOSUB 1400:GOTO 900
  211. 851 IF SYSOP THEN 900
  212. 852 A$=FIRST$+", there are "+STR$(BULL)+" system bulletins today.  Do you wish to skip them":GOSUB 1500:IF YES THEN 900
  213. 860 FILE$=BULLETIN$:GOSUB 6000:GOSUB 9700   'CPC04
  214. 870 CR=2:GOSUB 1400:FIELD 1,10 AS A$,10 AS Y$,31 AS A$:GET 1,1:CALLN=VAL(Y$)+1 'CPC06
  215. 900 'Search for any messages to this caller ------
  216. 905 A$="":GOSUB 1400:A$="Checking message file...":CR=2:IF NOT LOCAL THEN GOSUB 1400 'CPC06
  217. 910 X=37:Y=31:F$=NAM$:T=0:DONE=0:R=1
  218. 915 FOR R=1 TO LASTR
  219. 920 GET 1,M(R,1):IF INSTR(MID$(R$,37,31),NAM$)=0 THEN IF NOT SYSOP THEN 940
  220. 922 IF NOT SYSOP THEN IF T THEN 935 ELSE 925 ELSE 923
  221. 923 IF INSTR(MID$(R$,37,31),NAM$)=0 AND INSTR(MID$(R$,37,31),NFIR$+" "+NLAS$)=0 THEN 940 ELSE IF T THEN 935
  222. 925 A$="The following message(s) may be for you.":GOSUB 1400
  223. 930 A$="Please <K>ill those that would not interest other callers.":CR=2:GOSUB 1400:T=-1
  224. 935 A$=LEFT$(R$,5):CR=1:GOSUB 1400
  225. 940 NEXT
  226. 942 IF NOT T THEN A$="Sorry, "+FIRST$+", no personal mail for you today.":GOSUB 1400 'CPC06
  227. 945 CR=2:GOSUB 1400:FIELD 1,10 AS A$,10 AS Y$,31 AS A$:GET 1,1:CALLN=VAL(Y$)+1 'CPC06
  228. 946 IF NOT SYSOP THEN LSET A$=NAM$:LSET Y$=STR$(CALLN):PUT 1,1
  229. 948 A$="Entering the message subsystem...":GOSUB 1400:GOSUB 950:GOTO 955
  230. 950 IF PRT THEN C.C=CSRLIN:C.L=POS(0):LOCATE 25,1:PRINT SPACE$(79-(LEN(NAM$)+13))+NAM$+"  "+TIM$;:LOCATE C.C,C.L:RETURN ELSE RETURN
  231. 955 GOSUB 4900:STI=-1:IF NEWCALR THEN FILE$=NEWUSER$:GOSUB 6000:GOSUB 1700
  232. 1200 'Command Dispatcher ------------------
  233. 1210 STI=-1:Q=0
  234. 1220 GOSUB 1400
  235. 1230 IF NOT SYSOP THEN 1235 'CPC06
  236. 1231 IF XPR THEN A$="Sysop <1,2,3,4,5,6,7,8,9,10,11>":GOSUB 1400:ELSE GOSUB 10000
  237. 1232 GOTO 1240 'CPC06
  238. 1235 GOSUB 1400:GOSUB 41000:A$="Time remaining = "+TR$+" min.":GOSUB 1400 'CPC01
  239. 1240 IF XPR THEN 1250 ELSE GOSUB 50100 'CPC01
  240. 1250 GOSUB 1400:A$="Function <B,C,E,F,G,H,K,L,M,N,O,P,PL,PW,Q,R,S,T,U,W,X,#,?,!,$>" 
  241. 1260 GOSUB 1500:IF Q=0 THEN 1250
  242. 1270 FOR J=1 TO Q
  243. 1275 Z$=B$(J):GOSUB 5000:IF Z$="10" AND SYSOP THEN GOSUB 12000 'CPC09
  244. 1276 Z$=B$(J):GOSUB 5000:IF Z$="11" AND SYSOP THEN 10700
  245. 1280 Z$=B$(J):GOSUB 5000:IF Z$="PW" THEN 5100 ELSE IF Z$="PL" THEN 5200
  246. 1290 FF=INSTR("?BCEFGHKLMNOPQRSTWX#U!$123456789",Z$) 
  247. 1300 IF FF=0 THEN 1350 ELSE IF FF>23 AND NOT SYSOP THEN 1350 '
  248. 1310 '           ?    B    C    E    F     G     H    K    L    M     N    O    P
  249. 1320 ON FF GOSUB 1700,1720,1800,2000,20000,10560,1740,3900,4100,10960,5500,4700,4200,4320,4330,4340,9100,1760,4240,4900,10090,900,9300,10070,10090,10110,10270,10390,10490,10530,11000,9500
  250. 1330 '
  251. 1340 NEXT J:GOTO 1200
  252. 1350 IF XPR THEN 1240 ELSE GOSUB 1400
  253. 1360 A$=FIRST$+", I don't understand "+B$(J)+".":GOSUB 1400:GOTO 1200 'CPC01
  254. 1400 RET=0' Print string --------------------------
  255. 1405 IF NOT STI OR CHAT THEN 1435 'CPC03
  256. 1410 Y$=INKEY$:IF LOCAL THEN 1430
  257. 1415 IF EOF(3) THEN GOSUB 42000:GOTO 1430 'CPC06
  258. 1416 ON ERROR GOTO 13000 'CPC09
  259. 1420 Y$=INPUT$(1,#3) 'CPC06
  260. 1425 IF Y$=PAUSE$ THEN WHILE EOF(3):GOSUB 42000:WEND:GOTO 1420 'CTL S
  261. 1427 'CPC06
  262. 1430 IF Y$=ABT$ AND STI THEN 1475        ' Ctrl-K
  263. 1435 IF PRT THEN LOCATE ,,1:PRINT A$; 'CPC07
  264. 1437 IF LOCAL THEN 1450 'CPC01
  265. 1440 IF UC THEN SWAP A$,Z$:GOSUB 5000:SWAP A$,Z$
  266. 1445 PRINT #3,A$;
  267. 1450 IF CR=1 THEN 1470
  268. 1455 PRINT:IF LOCAL THEN 1465
  269. 1460 PRINT #3,"":IF LF THEN PRINT #3,LF$;
  270. 1465 IF CR=2 THEN CR=0:GOTO 1455
  271. 1470 Y$="":A$="":CR=0:RETURN
  272. 1475 CLOSE 2:CR=2:A$="":RET=STI:STI=0:GOSUB 1410:STI=RET:RET=-1:GOTO 1470
  273. 1500 'Input string --------------------------------
  274. 1502 GOSUB 42000:A!=FRE("A"):TOUT!=FNTI! 'CPC10
  275. 1505 A=0:B=0:C=0:Q=1:EOL=0:YES=0:B$="":NO=0
  276. 1510 A$=A$+"? ":CR=1:GOSUB 1400
  277. 1515 '
  278. 1520 IF LOCAL THEN LINE INPUT"",B$:GOTO 1575:ELSE IF BELL THEN PRINT#3,BELL$;
  279. 1525 WHILE EOF(3) 'CPC06
  280. 1526 GOSUB 42000 'CPC01
  281. 1527 MMM!=FNTI!-TOUT! 'CPC10
  282. 1528 IF MMM!>TIME.OUT! THEN RUN 90 'CPC01
  283. 1530 Y$=INKEY$:IF Y$<>"" THEN 1545
  284. 1535 WEND:IF INP(MSR)<128 THEN 13540
  285. 1540 Y$=INPUT$(1,3)
  286. 1544 IF Y$=CHR$(127) THEN 1635 'CPC03
  287. 1545 IF Y$=BK2$ THEN 1635
  288. 1550 IF Y$<" " AND Y$<>CR$ THEN 1525
  289. 1555 IF PRT THEN PRINT Y$; 'CPC01
  290. 1557 IF NOT SECURE THEN PRINT #3,Y$; ELSE PRINT #3,"."; 'CPC03
  291. 1560 IF Y$=CR$ THEN 1570
  292. 1563 IF LEN(B$)=>254 THEN A$="Input string too long. Try again.":GOSUB 1400:GOTO 1500
  293. 1565 B$=B$+Y$:GOTO 1525
  294. 1570 IF LF THEN PRINT #3,LF$;
  295. 1575 A=INSTR(B$,";"):IF A=0 THEN 1620
  296. 1580 B$(1)=LEFT$(B$,A-1):A=A+1
  297. 1585 B=INSTR(A,B$,";")
  298. 1590 C=B-A:IF C<1 THEN EOL=-1:C=128
  299. 1595 BB$=MID$(B$,A,C)
  300. 1600 IF BB$<>"" THEN Q=Q+1:B$(Q)=BB$
  301. 1605 IF NOT EOL AND Q<10 THEN A=B+1:GOTO 1585
  302. 1610 IF LEN(B$)>19 THEN A$="Try again, "+FIRST$+".":GOSUB 1400:GOTO 1500 'CPC01
  303. 1615 RETURN
  304. 1620 B$(1)=B$:IF B$="" THEN Q=0
  305. 1625 IF LEFT$(B$,1)="Y" OR LEFT$(B$,1)="y" THEN YES=-1
  306. 1627 IF LEFT$(B$,1)="N" OR LEFT$(B$,1)="n" THEN NO=-1
  307. 1630 RETURN
  308. 1635 IF LEN(B$)=0 THEN 1525
  309. 1640 B$=LEFT$(B$,LEN(B$)-1)
  310. 1645 IF PRT THEN PRINT BK1$; 'CPC06
  311. 1650 PRINT #3,BK$;:GOTO 1525
  312. 1653 ' baud switching routines ------
  313. 1654 R1=INP(LCR):K1=R1 OR 128:OUT LCR,K1
  314. 1660 IF Q=384 THEN GOTO 1668
  315. 1662 IF Q=256 THEN GOTO 1674
  316. 1664 IF Q=96 THEN GOTO 1680
  317. 1666 RETURN
  318. 1668 OUT LSB,&H80:OUT MSB,&H1:GOTO 1684
  319. 1674 OUT LSB,&H0:OUT MSB,&H1:GOTO 1684
  320. 1680 OUT LSB,&H60:OUT MSB,&H0
  321. 1684 OUT LCR,R1:RETURN
  322. 1700 '? Type Functions Supported ------------------
  323. 1710 FILE$=HELP02$:GOSUB 6000:RETURN
  324. 1720 'Type Bulletins ------------------------------
  325. 1721 IF BULL<1 THEN A$="Sorry, "+FIRST$+" there are no system bulletins today.":GOSUB 1400:RETURN
  326. 1730 ERR.LAST=0:FILE$=BULLETIN$:GOSUB 6000:IF ERR.LAST <> 53 THEN GOSUB 9700:RETURN ELSE RETURN
  327. 1740 'Type Help File ------------------------------
  328. 1750 FILE$=HELP01$:GOSUB 6000:RETURN
  329. 1760 'Type Welcome --------------------------------
  330. 1770 FILE$=WELCOME$:GOSUB 6000:RETURN
  331. 1800 'Comments ------------------------------------
  332. 1810 GOSUB 1400:A$="Comments are readable by Sysop only.":GOSUB 1400:MARGIN=72
  333. 1820 A$="Do you wish to leave a comment":GOSUB 1500
  334. 1830 IF NOT YES THEN A$="No comment.":GOSUB 1400:RETURN
  335. 1840 T$="SYSOP":SUB$="COMMENTS":SC=-1:LI=0:FOR I=1 TO 30:A$(I)="":NEXT 'CPC04
  336. 1850 GOSUB 1400:A$="Enter up to 20 lines (lone C/R to end).":GOSUB 1400 'CPC01
  337. 1860 GOSUB 1400:GOSUB 3200
  338. 1870 LI=LI+1:A$=RIGHT$(STR$(LI),2)+": "+A$(LI)
  339. 1880 CR=1:GOSUB 1400:GOSUB 3700
  340. 1890 IF A$(LI)="" THEN LI=LI-1:IF LI<1 THEN RETURN ELSE 2300 'CPC04
  341. 1900 IF LI=18 THEN A$="Two lines left...":GOSUB 1400
  342. 1910 IF LI=19 THEN A$="Last line.":GOSUB 1400
  343. 1920 IF LI=20 AND NOT SYSOP THEN A$="Comment full.":GOSUB 1400:GOTO 2300
  344. 1930 GOTO 1870
  345. 1940 CLOSE 2:OPEN "A",#2,COMMENTS$
  346. 1950 GOSUB 1400:A$="Many thanks for the comments, "+FIRST$+" !":GOSUB 1400 'CPC01
  347. 1960 GOSUB 482:PRINT #2,NAM$,D$,TIM$
  348. 1970 FOR X=1 TO LI:PRINT #2,A$(X):NEXT
  349. 1980 FOR X=1 TO 2:PRINT #2,CR$:NEXT:CLOSE 2:RETURN
  350. 2000 'Enter A Message -----------------------------
  351. 2005 GOSUB 1400:IF LASTR=MESSAGE.MAX THEN A$="Too many active messages -- try again another day.":GOSUB 1400:RETURN 1200 'CPC09
  352. 2007 Z$=MESSAGES$:GOSUB 52000:IF VAL(ACUM$)<2000 THEN A$="Not enough free disk space to store another message -- try another day.":GOSUB 1400:RETURN 1200
  353. 2010 T$="":PAS$="":LI=0:L=0:X=0:SC=0:FOR I=1 TO 30:A$(I)="":NEXT
  354. 2015 A$="Message will be # "+STR$(LASTM+1):GOSUB 1400
  355. 2020 A$="To (C/R  For All)":GOSUB 1500
  356. 2025 IF LEN(B$(1))>30 THEN A$="30 Chars max.":GOSUB 1400:GOTO 2020
  357. 2030 IF Q=0 THEN T$="ALL" ELSE Z$=B$(1):GOSUB 5000:T$=Z$
  358. 2035 A$="Subject":GOSUB 1500
  359. 2040 IF LEN(B$(1))>25 THEN A$="25 Chars max.":GOSUB 1400:GOTO 2035
  360. 2045 IF Q=0 THEN RETURN 1200 ELSE Z$=B$(1):GOSUB 5000:SUB$=Z$
  361. 2050 A$="Protect  <K,R,N,H,?>":IF XPR THEN 2060
  362. 2055 A$="Protect  < K)ill, R)ead, N)one, H)elp >" 'CPC03
  363. 2060 GOSUB 1500:IF Q=0 THEN 2050 ELSE Z$=LEFT$(B$(1),1):GOSUB 5000:X=INSTR("KRNH?",Z$)
  364. 2065 ON X GOTO 2085,2075,2100,2070,2055:GOTO 2050
  365. 2070 FILE$=HELP03$:GOSUB 6000:GOTO 2050
  366. 2075 IF T$<>"ALL" THEN 2084
  367. 2080 A$="YOU CANNOT PROTECT THIS MESSAGE":GOSUB 1400:GOTO 2050
  368. 2084 PAS$="^READ^":GOTO 2100
  369. 2085 A$="Password":GOSUB 1500
  370. 2090 IF LEN(B$(1))>15 THEN A$="15 Chars. max.":GOSUB 1400:GOTO 2085
  371. 2095 PAS$=B$(1)
  372. 2100 GOSUB 1400:IF XPR THEN 2120
  373. 2105 A$="To enter message, type in message text.":GOSUB 1400
  374. 2110 A$="Type empty return to end (19 lines max.).":GOSUB 1400 'CPC01
  375. 2120 GOSUB 3200
  376. 2125 LI=LI+1:A$=RIGHT$(STR$(LI),2)+": "+A$(LI)
  377. 2130 CR=1:GOSUB 1400:GOSUB 3700
  378. 2135 IF A$(LI)="" THEN LI=LI-1:GOTO 2300
  379. 2140 IF LI=17 THEN A$="Two lines left...":GOSUB 1400
  380. 2145 IF LI=18 THEN A$="Last line.":GOSUB 1400
  381. 2150 IF LI=19 AND NOT SYSOP THEN A$="Message full.":GOSUB 1400:GOTO 2300
  382. 2155 GOTO 2125
  383. 2300 'Editing dispatcher --------------------------
  384. 2305 GOSUB 1400
  385. 2310 IF XPR THEN 2315 ELSE GOSUB 50400 'CPC01
  386. 2315 GOSUB 1400:A$="Subfunction <A,C,D,E,I,L,M,S,?>" 'CPC01
  387. 2320 GOSUB 1500:IF Q=0 THEN 2315 ELSE Z$=B$(1):GOSUB 5000
  388. 2325 IF Q>1 AND Z$<>"M" THEN L=VAL(B$(Q)):GOSUB 3320
  389. 2330 FF=INSTR("ACDEILMS?",Z$):IF FF<1 OR FF>9 THEN 2310
  390. 2335 ON FF GOTO 2400,2340,2500,2600,2800,3000,3100,3400,2345
  391. 2340 GOSUB 3200:GOTO 2140
  392. 2345 FILE$=HELP04$:GOSUB 6000:GOTO 2315
  393. 2400 'Abort ---------------------------------------
  394. 2410 GOSUB 1400:A$="Abort this message":GOSUB 1500
  395. 2420 IF NOT YES THEN 2300
  396. 2430 GOSUB 1400:A$="Aborted":GOSUB 1400:RETURN 1200
  397. 2500 'Delete A Line -------------------------------
  398. 2510 GOSUB 1400:IF Q=1 THEN A$="Delete ":CR=1:GOSUB 1400:GOSUB 3300
  399. 2520 A$="Line #"+STR$(L):GOSUB 1400:A$=A$(L):CR=2:GOSUB 1400
  400. 2530 A$="Delete this line":GOSUB 1500
  401. 2540 IF NOT YES THEN A$="Line #"+STR$(L)+" NOT Deleted.":GOSUB 1400:GOTO 2300
  402. 2550 LI=LI-1:FOR X=L TO LI:A$(X)=A$(X+1):NEXT:A$(LI+1)=""
  403. 2560 A$="Line #"+STR$(L)+" Deleted.":GOSUB 1400:GOTO 2300
  404. 2600 'Edit A Line ---------------------------------
  405. 2610 GOSUB 1400:IF Q=1 THEN GOSUB 3300
  406. 2620 A$="Line #"+STR$(L)+" is:":GOSUB 1400:A$=A$(L):CR=2:GOSUB 1400
  407. 2630 A$="Enter <Oldstring;Newstring> or C/R for no change.":GOSUB 1400
  408. 2640 GOSUB 1400:GOSUB 1500
  409. 2650 IF Q=0 THEN 2300
  410. 2660 X=INSTR(1,A$(L),B$(1)):IF X=0 THEN 2710
  411. 2670 LB1=LEN(B$(1)):LB2=LEN(B$(2)):IF LB1<>LB2 THEN 2690
  412. 2680 MID$(A$(L),X)=B$(2):GOTO 2620
  413. 2690 C$=MID$(A$(L),X+LB1):CC$=LEFT$(A$(L),X-1)
  414. 2700 A$(L)=CC$+B$(2)+C$:GOTO 2620
  415. 2710 A$="String <"+B$(1)+"> not found in line"+STR$(L)+".":GOSUB 1400:GOTO 2300
  416. 2800 'Insert A Line -------------------------------
  417. 2810 IF LI=20 AND NOT SYSOP THEN 2300 ELSE FOR I=1 TO 30:C$(I)="":NEXT
  418. 2820 GOSUB 1400:IF Q=1 THEN A$="Before ":CR=1:GOSUB 1400:GOSUB 3300
  419. 2830 W=LI:K=LI-L:FOR X=L TO LI:C$(X+1-L)=A$(X):A$(X)="":NEXT:LI=L
  420. 2840 A$=RIGHT$(STR$(LI),2)+": "
  421. 2850 CR=1:GOSUB 1400:GOSUB 3700
  422. 2860 IF A$(LI)="" THEN 2920
  423. 2870 LI=LI+1
  424. 2880 IF LI+K=18 THEN A$="Two lines left...":GOSUB 1400
  425. 2890 IF LI+K=19 THEN A$="Last line.":GOSUB 1400
  426. 2900 IF LI+K=20 AND NOT SYSOP THEN A$="Message full.":GOSUB 1400:GOTO 2920
  427. 2910 GOTO 2840
  428. 2920 FOR X=1 TO K+1:A$(LI+X-1)=C$(X):NEXT:LI=W+LI-L
  429. 2930 GOTO 2300
  430. 3000 STI=-1'List Lines ----------------------------
  431. 3010 GOSUB 1400:IF Q=1 THEN L=1:A$="To: "+T$+" Re: "+SUB$:GOSUB 1400:GOSUB 3200
  432. 3020 FOR X=L TO LI:IF RET THEN 2300 ELSE A$=RIGHT$(STR$(X),2)+": "+A$(X)
  433. 3030 GOSUB 1400:NEXT:GOTO 2300
  434. 3100 'Set Right Margin ----------------------------
  435. 3110 GOSUB 1400:IF Q<>1 THEN B$(1)=B$(Q):GOTO 3130
  436. 3115 A$="Right-Margin is set at"+STR$(MARGIN):GOSUB 1400
  437. 3120 A$="Set Right-Margin to (8,16,24,32,40,48,56,64,72)":GOSUB 1500 'CPC01
  438. 3130 X=VAL(B$(1)):IF X>0 AND X<81 AND X MOD 8=0 THEN 3150 'CPC01
  439. 3140 A$="Invalid - Margin remains at"+STR$(MARGIN)+".":GOSUB 1400:IF MAINMARG THEN RETURN ELSE GOTO 2300 'CPC09
  440. 3150 MARGIN=VAL(B$(1)):A$="Margin now set to"+STR$(MARGIN)+".":GOSUB 1400:IF MAINMARG THEN RETURN ELSE GOTO 2300 'CPC09
  441. 3200 'Print Tab Settings --------------------------
  442. 3210 GOSUB 1400:A$="    ["+STRING$(MARGIN-2,45)+"]":GOSUB 1400:RETURN
  443. 3300 'Test Line Number ----------------------------
  444. 3310 A$="Line #":GOSUB 1500:L=VAL(B$(1))
  445. 3320 IF L=>1 AND L=<LI THEN RETURN
  446. 3330 IF Q=0 THEN RETURN 2300
  447. 3340 A$="No such line, "+FIRST$+".":GOSUB 1400:RETURN 2300 'CPC01
  448. 3400 'Save Message --------------------------------
  449. 3405 IF SC THEN 1940
  450. 3410 GOSUB 1400:A$="Updating Message file.":CR=1:GOSUB 1400
  451. 3440 X#=0:REC=0:N$="":LASTM=LASTM+1:LASTR=LASTR+1
  452. 3450 MNUM$=STR$(LASTM)+SPACE$(5-LEN(STR$(LASTM)))'1-5
  453. 3455 IF PAS$="^READ^" THEN MID$(MNUM$,1,1)="*"
  454. 3460 FROM$=NAM$+SPACE$(31-LEN(NAM$))'6-36
  455. 3470 T$=T$+SPACE$(31-LEN(T$)):MID$(T$,23,8)=TIME$'CPC04 37-67
  456. 3480 SUB$=SUB$+SPACE$(25-LEN(SUB$))'76-100
  457. 3490 PAS$=PAS$+SPACE$(15-LEN(PAS$))'101-115
  458. 3500 FOR J=1 TO LI:A$(J)=A$(J)+CHR$(227):REC=REC+LEN(A$(J)):NEXT
  459. 3510 IF REC MOD 128=0 THEN N$=STR$(REC\128+1) ELSE N$=STR$(REC\128+2)
  460. 3520 CLOSE 1:OPEN "R",1,MESSAGES$,128:FIELD 1,128 AS R$:X#=LOF(1)/128:GET 1:A$=SPACE$(8):LSET A$=STR$(LASTM):LSET R$=A$+MID$(R$,9,12)+NAM$:PUT 1,1
  461. 3530 GET 1,X#:M(LASTR,1)=X#+1:M(LASTR,2)=LASTM 'CPC06
  462. 3540 'CPC06
  463. 3550 LSET R$=MNUM$+FROM$+T$+D$+SUB$+PAS$+CHR$(225)+N$:PUT 1,M(LASTR,1) 'CPC06
  464. 3600 'Pack Disk Record ----------------------------
  465. 3610 N$="":FOR J=1 TO LI:A$=".":CR=1:GOSUB 1400
  466. 3620 N$=N$+A$(J):IF LEN(N$)>127 THEN LSET R$=N$:PUT 1:N$=MID$(N$,129)
  467. 3630 NEXT J
  468. 3640 LSET R$=N$:PUT 1:GOSUB 1400:RETURN 1200
  469. 3650 '
  470. 3700 'Word Processor ------------------------------
  471. 3710 RS$=A$(LI):COL=LEN(RS$):STI=0
  472. 3720 COL=COL+1
  473. 3730 IF LOCAL THEN X$=INPUT$(1):GOTO 3740
  474. 3732 TOUT!=FNTI!:WHILE EOF(3):MMM!=FNTI!-TOUT!:IF MMM!>TIME.OUT! THEN RUN 90 'CPC10
  475. 3733 GOSUB 42000:X$=INKEY$:IF LEN(X$)=1 THEN 3740 'CPC09
  476. 3734 WEND:X$=INPUT$(1,3)
  477. 3736 IF X$=LF$ THEN 3730
  478. 3738 IF X$=CHR$(127) THEN 3870 'CPC04
  479. 3740 IF X$=BK2$ THEN 3870
  480. 3750 A$=X$:CR=1:GOSUB 1400
  481. 3760 IF X$=CR$ THEN 3850
  482. 3770 IF COL>MARGIN-3 AND X$=" " THEN GOSUB 1400:GOTO 3850
  483. 3780 RS$=RS$+X$
  484. 3790 IF COL<MARGIN+1 THEN 3720
  485. 3800 Z=LEN(RS$)
  486. 3810 WHILE MID$(RS$,Z,1)<>" ":Z=Z-1:IF Z>0 THEN WEND ELSE Z=LEN(RS$)-1
  487. 3820 COL=MARGIN+1-Z:IF PRT THEN PRINT STRING$(COL,29);STRING$(COL,0); 'CPC01
  488. 3830 IF NOT LOCAL THEN PRINT #3,STRING$(COL,8);STRING$(COL,32);
  489. 3840 A$(LI)=LEFT$(RS$,Z):A$(LI+1)=RIGHT$(RS$,COL):GOSUB 1400:RETURN
  490. 3850 IF NOT LOCAL AND LF THEN PRINT #3,LF$;
  491. 3860 A$(LI)=RS$:RETURN
  492. 3870 IF COL=1 THEN 3730 ELSE COL=COL-2:RS$=LEFT$(RS$,LEN(RS$)-1)
  493. 3880 IF PRT THEN PRINT BK1$; 'CPC01
  494. 3885 IF NOT LOCAL THEN PRINT #3,BK$; 'CPC01
  495. 3890 GOTO 3720
  496. 3900 'Kill A Message ------------------------------
  497. 3910 GOSUB 1400
  498. 3920 IF Q<>1 THEN MM=VAL(B$(Q)):GOTO 3950
  499. 3930 A$="Msg # to Kill":GOSUB 1500:MM=VAL(B$(Q)):GOSUB 1400
  500. 3940 IF MM=0 THEN RETURN
  501. 3950 FOR Q=1 TO LASTR:IF M(Q,2)=MM THEN 3970 ELSE NEXT
  502. 3960 A$="There is no message # "+STR$(MM)+".":GOSUB 1400:RETURN 1200 'CPC01
  503. 3970 GET 1,M(Q,1):R=VAL(MID$(R$,118)):IF SYSOP THEN 4030
  504. 3980 Z=15:Z$=MID$(R$,101,15):GOSUB 8100:IF LEN(Z$)=0 THEN 4030
  505. 3990 IF Z$="^READ^" THEN IF INSTR(R$,NAM$) THEN 4030 ELSE 4020
  506. 4000 A$="Password (dots will echo)":SECURE=-1:GOSUB 1500:SECURE=0:GOSUB 1400 'CPC06
  507. 4010 IF B$(1)=Z$ THEN 4030
  508. 4020 A$="Sorry, wrong password. Message is protected.":GOSUB 1400:GOSUB 40000:RETURN 1200 'CPC01
  509. 4030 LSET R$=LEFT$(R$,115)+CHR$(226)+MID$(R$,117):PUT 1,LOC(1)
  510. 4040 GOSUB 135
  511. 4050 A$="Msg # "+STR$(MM)+" Killed.":GOSUB 1400:RETURN 1200
  512. 4100 'Toggle Line Feeds ---------------------------
  513. 4110 GOSUB 1400:LF=NOT LF
  514. 4120 A$="Line Feeds ":IF LF THEN A$=A$+"On" ELSE A$=A$+"Off"
  515. 4130 GOSUB 1400:GOSUB 50500:RETURN 'CPC06
  516. 4200 'Toggle Bell ---------------------------------
  517. 4210 GOSUB 1400:BELL=NOT BELL
  518. 4220 A$="Prompting Bell ":IF BELL THEN A$=A$+"On" ELSE A$=A$+"Off"
  519. 4230 GOSUB 1400:GOSUB 50500:RETURN 'CPC06
  520. 4240 'Toggle Expert -------------------------------
  521. 4250 GOSUB 1400:XPR=NOT XPR
  522. 4260 IF XPR THEN A$="Expert Mode" ELSE A$="Novice Mode"
  523. 4300 GOSUB 1400:GOSUB 50500:RETURN 'CPC05
  524. 4310 'Quick Scan & Summary & Retrieval ------------
  525. 4320 QU=-1:RT=0:SU=0:GOTO 4350 'Quick Scan Entry Point
  526. 4330 QU=0:RT=-1:SU=0:GOTO 4350 'Retreival  Entry Point
  527. 4340 QU=0:RT=0:SU=-1          'Summarize  Entry Point
  528. 4350 IF Q>2 AND VAL(B$(Q))=0 THEN Z$=B$(Q):Q=Q-1 ELSE Z$=""
  529. 4360 GOSUB 5000:SC$=Z$:L=1:LI=Q
  530. 4370 L=L+1:IF L<=LI THEN MM=VAL(B$(L)):GOTO 4415
  531. 4380 A$="Msg # ("+STR$(FIRSTM)+" to"+STR$(M(LASTR,2))+", *, <H>elp)":IF XPR THEN 4400 'CPC04
  532. 4390 IF RT THEN A$=A$+" to Retrieve (C/R to end)" ELSE A$="Starting at "+A$
  533. 4400 GOSUB 1500:IF LEFT$(B$(1),1)="H" OR LEFT$(B$(1),1)="h" THEN FILE$=HELP07$:GOSUB 6000:RETURN 1200 ELSE IF Q=0 THEN RETURN 1200 ELSE L=0:LI=Q:GOTO 4370 'CPC04
  534. 4410 '
  535. 4415 FOW=0:REV=0'Forward Flag, Reverse Flag
  536. 4420 IF B$(L)="*" THEN MM=LMSG+1:FOW=-1 ELSE IF MM=0 THEN RETURN 1200 ELSE GOSUB 1400
  537. 4430 IF RIGHT$(B$(L),1)="+" THEN FOW=-1
  538. 4440 IF RIGHT$(B$(L),1)="-" THEN REV=-1:GOTO 4490
  539. 4450 FOR R=1 TO LASTR
  540. 4460 IF RT AND M(R,2)=MM THEN 4520
  541. 4470 IF ((RT AND FOW) OR QU OR SU) AND M(R,2)=>MM THEN 4520
  542. 4480 NEXT:GOTO 4515
  543. 4490 FOR R=LASTR TO 1 STEP -1
  544. 4500 IF M(R,2)<=MM THEN 4540
  545. 4510 NEXT
  546. 4515 A$="Sorry, "+FIRST$+", there is no message #"+STR$(MM)+".":GOSUB 1400:GOTO 4370 'CPC03
  547. 4520 QQQ=R:IF RT AND NOT FOW THEN 4560
  548. 4530 QQ=R:QQQ=LASTR:QQQQ=1:GOTO 4550
  549. 4540 QQ=R:QQQ=1:QQQQ=-1
  550. 4550 FOR R=QQ TO QQQ STEP QQQQ
  551. 4555 '
  552. 4560 GET 1,M(R,1)
  553. 4565 PROTEC=0 'CPC06
  554. 4570 IF NOT SYSOP THEN IF INSTR(R$,"^READ^")>0 AND INSTR(R$,NAM$)=0 THEN PROTEC=-1 'CPC06
  555. 4580 IF INSTR(R$,SC$)=0 THEN 4635 'CPC06
  556. 4585 IF PROTEC THEN SUBJ$="<PROTECTED>" ELSE SUBJ$=MID$(R$,76,25) 'CPC06
  557. 4590 IF QU THEN Z$=LEFT$(R$,5)+" "+SUBJ$:Z=31:GOSUB 8100:A$=Z$:GOSUB 1400:GOTO 4630 'CPC06
  558. 4600 GOSUB 8000:IF SU OR RET THEN 4630 ELSE IF M(R,2)>LMSG THEN LMSG=M(R,2) 'CPC06
  559. 4610 IF PROTEC THEN GOSUB 4670 ELSE GOSUB 9000 'CPC09
  560. 4615 GOSUB 1400 'CPC06
  561. 4620 IF (R<>QQQ OR L<>LI) AND Q AND PL<>0 THEN A$="End of item. More":GOSUB 1500:IF NO THEN 4650
  562. 4625 IF NOT FOW AND NOT REV THEN 4370
  563. 4630 IF RET THEN RETURN 1200
  564. 4635 NEXT R 'CPC04
  565. 4640 'continue CPC04
  566. 4645 IF RT THEN 4370
  567. 4650 GOSUB 1400:A$="End of Msgs.":GOSUB 1400:RETURN 1200
  568. 4660 'CPC09
  569. 4670 GOSUB 1400:A$="Sorry, "+FIRST$+", msg # "+LEFT$(R$,5)+" is read protected."
  570. 4680 GOSUB 1400:RETURN 'CPC09
  571. 4700 'O Chat --------------------------------------
  572. 4702 IF NOT AVAILABLE GOTO 4750
  573. 4705 GOSUB 1400:A$="Chat... Remote Conversation Utility.":CR=2:GOSUB 1400
  574. 4706 'removed CPC05
  575. 4707 TRY.BELL=VAL(MID$(TIME$,1,2))*100+VAL(MID$(TIME$,4,2)):IF (TRY.BELL>ANNOY.ON AND TRY.BELL<ANNOY.OFF) AND ANNOY THEN 4710 'CPC06
  576. 4708 A$="Operator doesn't want to be bugged... try again another time "+FIRST$+".":GOSUB 1400:GOTO 4755 'CPC04
  577. 4710 A$="Program returns to command level within":GOSUB 1400
  578. 4715 A$="30 seconds if operator is unavailable.":CR=2:GOSUB 1400 'CPC01
  579. 4720 K=0:A$="Alerting operator now...":CR=1:GOSUB 1400 'CPC01
  580. 4725 IWAIT!=FNTI!+30
  581. 4730 IWAT!=FNTI!+1
  582. 4731 IF FNTI!<IWAT! GOTO 4731
  583. 4735 K=K+1:IF INKEY$=ESC$ THEN 4765
  584. 4740 A$=". ":IF K MOD 2 THEN A$=A$+BELL$
  585. 4744 IF LPRT THEN LPRINT BELL$;
  586. 4745 CR=1:GOSUB 1400:IF FNTI!<IWAIT! GOTO 4730 ELSE GOSUB 1400
  587. 4750 A$="Sorry "+FIRST$+", no operator available.":GOSUB 1400
  588. 4755 A$="Please leave a message on the board or in the comments."
  589. 4760 GOSUB 1400:RETURN
  590. 4765 GOSUB 1400:A$="Operator is available. Go ahead...":CR=2:GOSUB 1400 'CPC03
  591. 4770 'Forced chat enters here CPC03
  592. 4772 CHAT=TRUE 'CPC03
  593. 4775 WHILE EOF(3):A$=INKEY$
  594. 4780 IF A$=BK2$ OR A$=CHR$(127) THEN 4805 ELSE IF A$=ESC$ THEN CHAT=FALSE:CLS:KEY (10) ON:RETURN 1200
  595. 4785 IF A$=CR$ AND LF THEN PRINT #3,LF$;
  596. 4790 IF A$<>"" THEN CR=1:GOSUB 1400:GOTO 4775
  597. 4795 WEND
  598. 4797 A$=INPUT$(1,#3):IF A$=BK2$ THEN 4805 ELSE IF A$=CR$ AND LF THEN PRINT #3,LF$;
  599. 4800 CR=1:GOSUB 1400:GOTO 4775
  600. 4805 IF POS(0)>1 THEN PRINT BK1$;:PRINT #3,BK$;
  601. 4810 GOTO 4775
  602. 4900 '# Counters ----------------------------------
  603. 4910 GOSUB 1400
  604. 4920 A$="You are caller #  ->"+STR$(CALLN):GOSUB 1400
  605. 4930 A$="# of Active msgs  ->"+STR$(LASTR):GOSUB 1400
  606. 4940 IF LMSG>0 THEN A$="Last msg you read ->"+STR$(LMSG):GOSUB 1400
  607. 4950 A$="Next msg # will be->"+STR$(LASTM+1):GOSUB 1400:RETURN
  608. 5000 'Convert Lower Case to Upper Case ------------
  609. 5010 FOR Z=1 TO LEN(Z$)
  610. 5020 MID$(Z$,Z,1)=CHR$(ASC(MID$(Z$,Z,1))+32*(ASC(MID$(Z$,Z,1))>96))
  611. 5030 NEXT Z:RETURN
  612. 5100 'Change Password Function ------------------------
  613. 5110 A$="What would you like for a new password":SECURE=-1:GOSUB 1500:SECURE=0:GOSUB 1400:IF Q=0 THEN 1200 ELSE IF LEN(B$(1))>15 THEN 5110 ELSE Z$=B$(1):GOSUB 5000 'CPC06
  614. 5120 A$="Type new password again ":SECURE=-1:GOSUB 1500:SECURE=0:GOSUB 1400:IF Q=0 THEN 1200 ELSE SWAP Z$,B$(1):GOSUB 5000:IF Z$<>B$(1) THEN A$="Passwords don't match.":GOSUB 1400:GOTO 1200 'CPC06
  615. 5130 GOSUB 9400:GET 2,UIX#:LSET PW$=Z$:PUT 2,UIX#:CLOSE 2:GOSUB 1400:A$="Password change complete. ":GOSUB 1400:GOTO 1200  'CPC04
  616. 5200 'Change Page Length Function --------------------------------
  617. 5210 IF Q>1 THEN 5230
  618. 5220 A$="Page length is"+STR$(PL)+". Enter new page length or zero for continuous":GOSUB 1500:IF Q=0 THEN 1200
  619. 5230 A=VAL(B$(Q)):IF A<0 OR A>255 THEN 5220 ELSE PL=A:GOTO 1200
  620. 5500 'Swap baud rate 300 <=> 450 ------------------
  621. 5505 IF BPS=-1 THEN A$="Sorry, 1200 baud connect cannot change speed.":GOSUB 1400:RETURN 'CPC01
  622. 5507 A$="Do you wish to change to 450 baud":GOSUB 1500:IF NOT YES THEN RETURN 'CPC03
  623. 5510 A$="Change baud rate to 450, then enter <c/r> until I respond...":GOSUB 1400:FOR X=1 TO 10000:NEXT:C=0 'CPC01
  624. 5520 SWAP Q,NBPS:GOSUB 1654:SWAP Q,NBPS
  625. 5530 C=C+1:GOSUB 42000:IF C=20 THEN 13540 ELSE IF ASC(INPUT$(1,3))=13 THEN 5540 ELSE 5530
  626. 5540 CLOSE 2:OPEN "A",2,CALLERS$ 'CPC04
  627. 5550 Z$="   == Switched to 450 baud ==":PRINT #2,Z$
  628. 5551 CLOSE 2:IF LPRT THEN LPRINT Z$
  629. 5555 A$="You are now at 450 baud, "+FIRST$:GOSUB 1400
  630. 5560 RETURN 'CPC04
  631. 6000 'Common Routine to Print  A File ---------------------------
  632. 6010 GOSUB 1400:A$="* Use <^K> to abort, <^S> to suspend *":CR=2:GOSUB 1400
  633. 6020 CLOSE #2:OPEN "I",#2,FILE$:Q=0:GOTO 6040
  634. 6030 Q=-1' NOTE: Download enters here
  635. 6040 IF EOF(2) OR (INP(MSR)<128 AND NOT LOCAL) THEN 6060
  636. 6045 IF PL AND Q>=0 THEN Q=Q+1:IF Q>=PL THEN A$="More":GOSUB 1500:IF NO THEN 6060 ELSE Q=0 'CPC06
  637. 6050 LINE INPUT #2,A$:GOSUB 6055:A$=A$+NUL$:GOSUB 1400:IF NOT RET THEN 6040 ELSE 6060
  638. 6055 IF FILE$=CALLERS$ AND NOT SYSOP THEN IF LEFT$(A$,1)=" " THEN A$=CHR$(0):RETURN ELSE RETURN ELSE RETURN
  639. 6060 Q=0:CLOSE 2:IF NOT LOCAL THEN GOSUB 42000:RETURN ELSE RETURN
  640. 6070 '
  641. 6080 A$="Please let the SYSOP know that file <"+FILE$+"> is missing!":GOSUB 1400:RETURN
  642. 7000 'Common Routine To Test Fields ----------------------------
  643. 7010 GET 1,R:RR=VAL(MID$(R$,118))
  644. 7020 IF RR<1 THEN DONE=-1:RETURN
  645. 7030 R=R+RR
  646. 7040 IF INSTR(MID$(R$,X,Y),F$) THEN RETURN
  647. 7050 GOTO 7010
  648. 8000 'Process Message Header ----------------------
  649. 8010 GOSUB 1400:IF RET THEN RETURN
  650. 8020 IF MID$(R$,37,3)="ALL" THEN T$="ALL":GOTO 8040
  651. 8030 Z=22:Z$=MID$(R$,37,Z):GOSUB 8100:T$=Z$ 'CPC04
  652. 8040 Z=25:Z$=MID$(R$,76,Z):GOSUB 8100:SUB$=Z$:IF PROTEC THEN SUB$=SUBJ$ 'CPC06
  653. 8050 Z=31:Z$=MID$(R$, 6,Z):GOSUB 8100:FROM$=Z$
  654. 8060 A$="Msg # "+LEFT$(R$,5)+" Dated "+MID$(R$,68,8)+" "+MID$(R$,59,8) 'CPC04
  655. 8065 GOSUB 1400:IF NOT RET THEN A$="From: "+FROM$ 'CPC04
  656. 8070 GOSUB 1400:IF NOT RET THEN  A$="  To: "+T$:GOSUB 1400:IF NOT RET THEN A$="  Re: "+SUB$:GOSUB 1400 'CPC04
  657. 8080 RETURN
  658. 8090 'Remove Spaces That Pad Msg Header -----------------------
  659. 8100 WHILE MID$(Z$,Z,1)=" ":Z=Z-1:IF Z>0 THEN WEND
  660. 8110 Z$=MID$(Z$,1,Z):RETURN
  661. 9000 'Unpack Disk Record --------------------------
  662. 9010 GOSUB 1400:Q=4
  663. 9020 FOR X=2 TO VAL(MID$(R$,118))
  664. 9030 CR=1:GOSUB 1400:EOL=0:J=1:GET 1
  665. 9040 '
  666. 9050 B=INSTR(J,R$,CHR$(227)):IF RET THEN RETURN ' catches all RET!
  667. 9060 C=B-J:IF C<1 THEN C=128:EOL=-1
  668. 9070 A$=MID$(R$,J,C):IF EOL THEN 9090
  669. 9075 GOSUB 1400:J=B+1
  670. 9080 IF PL THEN Q=Q+1:IF Q>=PL THEN A$="More":GOSUB 1500:Q=0:IF NO THEN RETURN
  671. 9085 GOTO 9050
  672. 9090 NEXT:A$="":RETURN
  673. 9100 'Time On System ------------------------------
  674. 9110 GOSUB 1400
  675. 9120 H=VAL(LEFT$(TI$,2)):M=VAL(MID$(TI$,4,2)):S=VAL(MID$(TI$,7,2))
  676. 9130 HH=VAL(LEFT$(TIME$,2)):MM=VAL(MID$(TIME$,4,2)):SS=VAL(MID$(TIME$,7,2))
  677. 9140 IF S=<SS THEN SSS=SS-S ELSE SSS=60-(S-SS):M=M+1
  678. 9150 IF M=<MM THEN MMM=MM-M ELSE MMM=60-(M-MM):H=H+1
  679. 9160 IF H=<HH THEN HHH=HH-H ELSE HHH=24-(H-HH)
  680. 9170 GOSUB 482:A$="It is now "+TIM$+".":GOSUB 1400
  681. 9180 A$="You have been on for":CR=1:GOSUB 1400
  682. 9190 IF HHH>0 THEN A$=STR$(HHH)+" Hours":CR=1:GOSUB 1400
  683. 9200 A$=STR$(MMM)+" Minutes and"+STR$(SSS)+" Seconds.":GOSUB 1400:RETURN
  684. 9300 'Sends 5 Null characters
  685. 9310 NULL=NOT NULL:IF NULL THEN NUL$=CHR$(0)+CHR$(0)+CHR$(0)+CHR$(0)+CHR$(0):A$="<Nulls> on" ELSE NUL$="":A$="<Nulls> off":GOSUB 1400
  686. 9320 RETURN
  687. 9400 'Routine to open users file ----------------------------
  688. 9410 CLOSE 2:OPEN "R",2,USERS$,128:FIELD 2,31 AS N$,15 AS PW$,1 AS ST$,15 AS OP$,24 AS CS$,20 AS MA$,14 AS TD$:RETURN
  689. 9500 'SYSOP AVAILABILITY-------------------------
  690. 9510 GOSUB 1400:AVAILABLE=NOT AVAILABLE
  691. 9520 A$="SYSOP is ":IF AVAILABLE THEN A$=A$+"available..." ELSE A$=A$+"not available...."
  692. 9530 GOSUB 1400:GET 1,1:MID$(R$,9,2)=STR$(AVAILABLE):PUT 1,1:RETURN
  693. 9700 ' BULLETIN SUBSYSTEM CPC04 ------------------------------
  694. 9710 GOSUB 1400:A$="Bulletin # <1 through"+STR$(BULL)+", L)ist or C/R to end>" 'CPC04
  695. 9720 GOSUB 1500:IF Q=0 THEN RETURN ELSE Z$=B$(1):GOSUB 5000 'CPC04
  696. 9730 FF=INSTR("123456L",Z$) 'CPC04
  697. 9740 IF FF<1 THEN 9710 'CPC04
  698. 9745 IF Z$="L" GOTO 9750
  699. 9746 IF INT(VAL(Z$))>BULL GOTO 9710
  700. 9750 ON FF GOSUB 9760,9770,9780,9790,9800,9810,9820
  701. 9755 RETURN 'Go back to login or main menu CPC04
  702. 9760 FILE$=BULLET1$:GOSUB 6000:GOTO 9700
  703. 9770 FILE$=BULLET2$:GOSUB 6000:GOTO 9700
  704. 9780 FILE$=BULLET3$:GOSUB 6000:GOTO 9700
  705. 9790 FILE$=BULLET4$:GOSUB 6000:GOTO 9700
  706. 9800 FILE$=BULLET5$:GOSUB 6000:GOTO 9700
  707. 9810 FILE$=BULLET6$:GOSUB 6000:GOTO 9700
  708. 9820 FILE$=BULLETIN$:GOSUB 6000:GOTO 9700
  709. 10000 'Sysop's Utilities ---------------------------
  710. 10010 'CPC06
  711. 10020 A$="Sysop's Utilities:":GOSUB 1400
  712. 10030 A$="  1  List comments    | 2  List callers log":GOSUB 1400
  713. 10040 A$="  3  Pack msg file    | 4  Renumber msg file":GOSUB 1400
  714. 10050 A$="  5  Recover a Msg    | 6  List message headers":GOSUB 1400
  715. 10060 A$="  7  Erase comments   | 8  Users file maintenance":GOSUB 1400
  716. 10065 A$="  9  Toggle page bell | 10 Pack users file":GOSUB 1400
  717. 10066 A$=" 11  Filespecs":CR=2:GOSUB 1400:RETURN
  718. 10070 '1 -------------------------------------------
  719. 10080 FILE$=COMMENTS$:GOSUB 6000:RETURN
  720. 10090 '2 -------------------------------------------
  721. 10100 FILE$=CALLERS$:GOSUB 6000:RETURN
  722. 10110 '3 -------------------------------------------
  723. 10111 A$="Do you want to pack MESSAGES file":GOSUB 1500:IF NO THEN RETURN 1200
  724. 10112 OK=0:NAME MESSAGES.BAK$ AS MESSAGES.BAK$ 'CPC06
  725. 10113 IF NOT OK THEN 10120 'CPC06
  726. 10115 KILL MESSAGES.BAK$
  727. 10120 CLOSE #1,2:NAME MESSAGES$ AS MESSAGES.BAK$:Q=0
  728. 10130 OPEN "R",#1,MESSAGES.BAK$:FIELD #1,128 AS R$
  729. 10140 OPEN "R",#2,MESSAGES$:FIELD #2,128 AS RR$:GET 1:GOTO 10240
  730. 10150 GET 1
  731. 10160 IF INSTR(R$,CHR$(225))>0 THEN 10220
  732. 10170 IF INSTR(R$,CHR$(227))>0 THEN 10240
  733. 10180 IF INSTR(R$,CHR$(226))>0 THEN 10250
  734. 10185 IF NOT EOF(1) THEN 10150
  735. 10190 GOSUB 1400:A$="# of Msgs Purged :"+STR$(Q):GOSUB 1400
  736. 10200 A$="# of Bytes Purged:"+STR$((LOC(1)*128)-(LOC(2)*128)):GOSUB 1400
  737. 10210 A$="Re-Loading Msg File...":GOSUB 1400:GOSUB 135:RETURN 1200
  738. 10220 A$="Msg #"+LEFT$(R$,5)+" copied...":GOSUB 1400
  739. 10240 LSET RR$=R$:PUT 2:GOTO 10150
  740. 10250 Q=Q+1:A$="Msg #"+LEFT$(R$,5)+"          purged...":GOSUB 1400
  741. 10260 GET 1,LOC(1)+VAL(MID$(R$,118)):GOTO 10160
  742. 10270 'Renumber ------------------------------------
  743. 10280 A$="Renumber starting with OLD msg #":GOSUB 1500:MM=VAL(B$(1))
  744. 10290 IF Q=0 OR MM<1 THEN RETURN 1200
  745. 10300 A$="Start with NEW #":GOSUB 1500:Y=VAL(B$(1)):YY=Y:IF Q=0 THEN 10280
  746. 10310 FOR Q=1 TO LASTR
  747. 10320 IF M(Q,2)=MM THEN R=M(Q,1):GOTO 10340
  748. 10330 NEXT:A$="No Msg #"+STR$(MM):GOSUB 1400:RETURN 1200
  749. 10340 GET 1,R
  750. 10350 RR=VAL(MID$(R$,118)):IF RR<1 THEN GET 1,1:Y=LASTR:LSET R$=STR$(Y+1)+SPACE$(5-LEN(STR$(Y)))+MID$(R$,6):PUT 1,1:GOTO 10210
  751. 10360 LSET R$=STR$(Y)+SPACE$(5-LEN(STR$(Y)))+MID$(R$,6)
  752. 10370 PUT 1,LOC(1)
  753. 10380 Y=Y+1:R=R+RR:GOTO 10340
  754. 10390 'Resurrection --------------------------------
  755. 10400 A$="Msg # to Recover":GOSUB 1500:MM=VAL(B$(1)):IF MM<1 THEN 1450
  756. 10410 R=2:GOSUB 1400
  757. 10420 GET 1,R:RR=VAL(MID$(R$,118))
  758. 10430 IF RR<1 THEN A$="No Msg #"+STR$(MM):GOSUB 1400:RETURN
  759. 10440 IF VAL(MID$(R$,2,4))<>MM THEN R=R+RR:GOTO 10420
  760. 10450 IF INSTR(R$,CHR$(226))=0 THEN 10480
  761. 10460 LSET R$=LEFT$(R$,115)+CHR$(225)+MID$(R$,117):PUT 1,LOC(1)
  762. 10470 A$="Msg #"+STR$(MM)+" is now alive and well.":GOSUB 1400:GOTO 10210
  763. 10480 A$="Msg #"+STR$(MM)+" is not Dead.":GOSUB 1400:RETURN
  764. 10490 'Print Msg Header ----------------------------
  765. 10500 R=2
  766. 10510 GET 1,R:RR=VAL(MID$(R$,118)):IF RR<1 THEN RETURN
  767. 10520 A$=R$:GOSUB 1400:R=R+RR:GOTO 10510
  768. 10530 'Purge Comments ------------------------------
  769. 10540 A$="Delete all comments":GOSUB 1500
  770. 10541 IF YES THEN CLOSE #2:OPEN "O",#2,COMMENTS$:CLOSE #2
  771. 10550 RETURN 1200
  772. 10560 'Goodbye -------------------------------------
  773. 10570 GOSUB 9100
  774. 10580 IF HHH>0 THEN CLOSE #2:OPEN "A",#2,LONGCALR$:WRITE#2,NAM$,D$,HHH,MMM:CLOSE #2
  775. 10590 A$="Thanks for calling, "+FIRST$+ "!":GOSUB 1400:CLOSE:IF SYSOP THEN RUN 90
  776. 10600 GOSUB 9400:GET 2,UIX#
  777. 10610 LSET OP$=MKI$(TIMON)+MKI$(LMSG)+MKI$(LF)+MKI$(MARGIN)+MKI$(BELL)+MKI$(XPR)+CHR$(PL)+STRING$(2,0):PUT 2,UIX#:CLOSE 2
  778. 10615 IF SYSOPNEXT THEN STOP ELSE RUN 90
  779. 10620 'Log-Off Weasels -----------------------------
  780. 10630 GOSUB 1400:A$="Please sign off. You are denied access.":CR=2:GOSUB 1400
  781. 10640 CLOSE 2,3:GOTO 200
  782. 10700 'Sysop function to view all filespecs
  783. 10710 GOSUB 1400:A$="Enter the filespec(s) as d:filespec.ext ":GOSUB 1500:GOSUB 5000:IF B$(1)="" THEN 1200 ELSE Z$=B$(1)
  784. 10715 A$="Reading directory don't despair ...":GOSUB 1400
  785. 10720 CLS:FILES B$(J)
  786. 10730 LINECT=CSRLIN
  787. 10740 G=0
  788. 10750 LOCATE 2,1,1
  789. 10760 FOR I=2 TO LINECT
  790. 10770 FOR B=1 TO 66 STEP 18
  791. 10780 G=G+1
  792. 10790 FOR P=0 TO 11
  793. 10810 H=SCREEN (I,(B+P)):FLS$(G)=FLS$(G)+CHR$(H)
  794. 10820 NEXT P
  795. 10830 IF LEFT$(FLS$(G),1)=" " THEN G=G-1:GOTO 10850
  796. 10840 NEXT B:NEXT I
  797. 10850 CLS
  798. 10860 GOSUB 1400:A$="Hang on... Alphabetizing filenames ":GOSUB 1400
  799. 10870 FOR X=1 TO G-1:FOR Y=X+1 TO G:IF FLS$(Y)<FLS$(X) THEN SWAP FLS$(X),FLS$(Y)
  800. 10880 NEXT Y:A$=".":CR=1:GOSUB 1400:NEXT X
  801. 10890 GOSUB 1400:A$="Filespecs":GOSUB 1400
  802. 10900 FOR I=1 TO G:FOR MMM=1 TO LEN(FLS$(I))
  803. 10910 L$=MID$(FLS$(I),MMM,1):IF ASC(L$)<>32 THEN W$=W$+L$
  804. 10920 NEXT MMM:FLS$(I)=W$
  805. 10930 A$=FLS$(I):GOSUB 1400
  806. 10940 W$="":NEXT I
  807. 10950 FOR I=1 TO 128:FLS$(I)="":NEXT:GOTO 1200
  808. 10960 'Main menu msg margin -----------
  809. 10970 MAINMARG=-1:GOSUB 3100:MAINMARG=0:RETURN
  810. 11000 'USERS file maintenance -------------------
  811. 11004 A$="<L>ist, <P>rint, or <M>odify users":GOSUB 1500:IF Q=0 THEN RETURN 1200 ELSE QQ=0:Z$=LEFT$(B$(1),1):GOSUB 5000:IF Z$="M" THEN STI=0 ELSE IF Z$="P" THEN QQ=-1
  812. 11005 GOSUB 9400:Z=1
  813. 11010 XY#=LOF(2)/128:FOR J=Z TO XY#:GET 2,J
  814. 11015 IF ASC(N$)=0 THEN 11300 ELSE A$=STR$(LOC(2))+":"+N$:IF ST$<>"Y" THEN A$=A$+" <Locked out>":GOTO 11100
  815. 11020 A$=A$+"Pw="+PW$+" Times on="+STR$(CVI(MID$(OP$,1,2)))
  816. 11025 IF QQ THEN LPRINT A$
  817. 11030 GOSUB 1400:A$="                  "+TD$+CS$+MA$
  818. 11100 IF QQ THEN LPRINT A$
  819. 11105 GOSUB 1400:IF STI THEN 11300
  820. 11110 A$="<D>elete, <F>ind, <L>ockout, <M>enu, <N>ew password, <P>rint, <#>user":GOSUB 1500:IF Q=0 THEN 11310
  821. 11115 Z$=LEFT$(B$(1),1):GOSUB 5000:X=INSTR("DNLPSMF",Z$)
  822. 11120 ON X GOTO 11130,11160,11190,11220,11250,11320,11340
  823. 11125 Z=VAL(B$):XY#=LOF(2)/128:IF Z<1 OR Z>XY# THEN 11310 ELSE 11010
  824. 11130 LSET N$=STRING$(31,0):GOTO 11290
  825. 11160 A$="Enter new password":GOSUB 1500:Z$=B$(1):GOSUB 5000:LSET PW$=Z$:GOTO 11290
  826. 11190 IF ST$="Y" THEN LSET ST$="L" ELSE LSET ST$="Y"
  827. 11195 GOTO 11290
  828. 11220 QQ=NOT QQ:GOTO 11015
  829. 11250 GOTO 11300
  830. 11290 PUT 2,LOC(2):GOTO 11015
  831. 11300 IF RET THEN 11320
  832. 11310 NEXT
  833. 11320 CLOSE 2:RETURN 1200
  834. 11340 GOSUB 1400:A$="Enter user name to find":GOSUB 1500:Z$=B$(1):GOSUB 5000:USERNAME$=Z$
  835. 11350 X$=USERNAME$+SPACE$(31-LEN(USERNAME$))
  836. 11360 GET 2:IF EOF(2) THEN 11380 ELSE IF ASC(N$)=0 THEN 11360
  837. 11370 IF X$<>N$ THEN 11360 ELSE GOTO 11015
  838. 11380 A$=USERNAME$+" not found in USERS file.":CR=2:GOSUB 1400:GOTO 11015
  839. 12000 'Pack users file by deleted and time lapse---------------------------
  840. 12002 A$="Do you want to pack USERS file":GOSUB 1500:IF NO THEN RETURN 1200
  841. 12005 OK=0:USERS.BAK$=USERS$+".BAK":NOW=VAL(LEFT$(DATE$,2)):NAME USERS.BAK$ AS USERS.BAK$
  842. 12010 IF NOT OK THEN 12030
  843. 12020 KILL USERS.BAK$
  844. 12030 NAME USERS$ AS USERS.BAK$:Q=0
  845. 12040 CLOSE 1:OPEN "R",1,USERS.BAK$,128:FIELD 1,31 AS OLD.N$,15 AS OLD.PW$,1 AS OLD.ST$,15 AS OLD.OP$,24 AS OLD.CS$,20 AS OLD.MA$,14 AS OLD.TD$
  846. 12050 CLOSE 2:OPEN "R",2,USERS$,128:FIELD 2,31 AS N$,15 AS PW$,1 AS ST$,15 AS OP$,24 AS CS$,20 AS MA$,14 AS TD$
  847. 12060 A!=LOF(1)/128:FOR J=1 TO A!
  848. 12065 GET 1,J
  849. 12070 IF ASC(OLD.N$)=0 THEN 12220
  850. 12080 ONLAST=VAL(LEFT$(OLD.TD$,2)):LAPSE=NOW-ONLAST:IF LAPSE<0 THEN LAPSE=LAPSE+12
  851. 12090 IF LAPSE>LAPSE.MAX THEN 12220
  852. 12200 A$=STR$(LOC(1))+": "+OLD.N$+" copied...":GOSUB 1400
  853. 12205 LSET N$=OLD.N$:LSET PW$=OLD.PW$:LSET ST$=OLD.ST$:LSET OP$=OLD.OP$:LSET CS$=OLD.CS$:LSET MA$=OLD.MA$:LSET TD$=OLD.TD$
  854. 12210 PUT 2:GOTO 12230
  855. 12220 Q=Q+1:A$=STR$(LOC(1))+": "+OLD.N$+"          purged...":GOSUB 1400
  856. 12230 NEXT
  857. 12240 GOSUB 1400:A$="# users purged:"+STR$(Q):GOSUB 1400
  858. 12250 A$="Reloading files...":GOSUB 1400:CLOSE 1,#2:GOSUB 135:GOSUB 9400:RETURN 1200
  859. 13000 'Error Trapping ------------------------------
  860. 13010 IF ERR=7 THEN 13650
  861. 13020 IF ERL=187 AND ERR=27 THEN LPRT=FALSE:RESUME 187
  862. 13030 IF ERL=841 AND ERR=27 THEN LPRT=FALSE:RESUME 841
  863. 13040 IF ERL=4744 AND ERR=27 THEN LPRT=FALSE:RESUME 4744
  864. 13050 IF ERL=5551 AND ERR=27 THEN LPRT=FALSE:RESUME 5551
  865. 13060 IF ERL=11025 AND ERR=27 THEN QQ=FALSE:RESUME 11025
  866. 13070 IF ERL=11100 AND ERR=27 THEN QQ=FALSE:RESUME 11100
  867. 13080 IF ERL=13110 AND ERR=27 THEN LPRT=FALSE:RESUME 13110
  868. 13090 IF ERR=58 THEN 13130
  869. 13100 IF (ERR=ERR.LAST AND (FNTI!-TIMERR!<5)) THEN ERR.COUNT=ERR.COUNT+1:IF ERR.COUNT>ERR.MAX THEN 50000
  870. 13110 IF (ERR<>53 AND ERR<>57 AND LPRT) THEN LPRINT "+++ Error";ERR;"  in line ";ERL " occurred at " TIME$ " on " DATE$
  871. 13120 ERR.LAST=ERR:IF FNTI!-TIMERR!>5 THEN ERR.COUNT=0 ELSE TIMERR!=FNTI!
  872. 13130 IF ERL=118 AND ERR=53 THEN 13550
  873. 13135 IF ERL=121 AND ERR=62 THEN 13550
  874. 13140 IF ERL=220 THEN RESUME 220
  875. 13150 IF (ERL=340 AND NOT BIT.8) THEN OUT LCR,&H3:RESUME 335
  876. 13160 IF ERL=340 THEN RESUME 345
  877. 13170 IF ERL<1200 THEN RESUME 13540
  878. 13180 IF ERL=1420 AND ERR=57 THEN R1=INP(LSR):RESUME 1425
  879. 13190 IF ERL=1540 OR ERL=3734 OR ERL=20840 OR ERL=21290 OR ERL=21360 OR ERL=21420 THEN GOSUB 13670:IF INP(MSR)<128 THEN RESUME 13540
  880. 13200 IF ERL=1540 THEN RESUME 1540
  881. 13210 IF ERL=3530 THEN RESUME 3550
  882. 13220 IF ERL=3734 THEN RESUME 3734
  883. 13230 IF ERL=4797 THEN GOSUB 13670:IF INP (MSR)<128 THEN RESUME 13540 ELSE RESUME 4797
  884. 13240 IF ERL=5530 AND ERR=57 THEN RESUME 20015
  885. 13250 IF ERL=5530 THEN RESUME 5530
  886. 13260 IF ERL=6020 THEN RESUME 6080
  887. 13270 IF ERL=6050 AND ERR=52 THEN RESUME 6060
  888. 13280 IF ERL=10600 AND ERR=63 THEN 13540
  889. 13290 IF ERL=10112 THEN IF ERR=58 THEN OK=-1:RESUME 10113 ELSE RESUME 10113
  890. 13300 IF ERL=10115 THEN RESUME 10120
  891. 13310 IF ERL=10720 AND ERR=53 THEN A$="That file doesn't exist or you gave an invalid filespec !!":GOSUB 1400:RESUME 10700
  892. 13320 IF ERL=12005 THEN IF ERR=58 THEN OK=-1:RESUME 12010 ELSE RESUME 12010
  893. 13330 IF ERL=12020 THEN RESUME 12030
  894. 13340 IF ERL=12210 AND ERR=61 THEN GOSUB 13600:RESUME 1200
  895. 13350 IF ERL=10240 AND ERR=61 THEN GOSUB 13610:RESUME 1200
  896. 13360 IF ERL=20220 AND ERR=53 THEN RESUME 20225
  897. 13370 IF ERL=20220 THEN IF ERR=58 THEN OK=-1:RESUME 20225 ELSE RESUME 20225
  898. 13380 IF ERL=20440 THEN IF ERR=53 THEN OK=-1:RESUME 20450 ELSE RESUME 20450
  899. 13390 IF ERL=20450 THEN OK=0:RESUME 20455
  900. 13400 IF ERL=20620 THEN OK=0:RESUME 20621
  901. 13410 IF ERL=20840 THEN RESUME 20840
  902. 13420 IF ERL=21130 THEN OK=0:RESUME 21131
  903. 13430 IF ERL=21290 THEN RESUME 21290
  904. 13440 IF ERL=21360 THEN RESUME 21360
  905. 13445 IF ERL=21420 THEN RESUME 21420
  906. 13450 IF ERL=65535! THEN 50000
  907. 13460 IF ERR=5 THEN 13540
  908. 13470 IF ERR=57 OR ERR=24 OR ERR=25 THEN FOR EXX=1 TO 500:NEXT:R1=INP(MSR):IF R1<128 THEN RESUME 13540 ELSE GOSUB 13580
  909. 13480 IF ERR=61 THEN GOSUB 1400:A$="<< Disk is full -- file operation abnormally terminated. >>":CR=2:GOSUB 1400:RESUME 1200
  910. 13490 IF ERR=71 THEN GOSUB 13630:RESUME 20020
  911. 13500 A$="You have located a software bug.":GOSUB 1400
  912. 13510 A$="Please leave a comment or a msg for SYSOP that":GOSUB 1400
  913. 13520 A$="Error "+STR$(ERR)+" occured in Line "+STR$(ERL)+".":GOSUB 1400
  914. 13530 A$="Thank You...":GOSUB 1400:PRINT:RESUME 1200
  915. 13540 RUN 90
  916. 13550 CLS:LOCATE ,,0
  917. 13560 PRINT CONFIG$+" file not found or invalid.  Please create one using "+VERSION$+"'s utility program -- CONFIG."
  918. 13570 FOR I=1 TO 10:GOSUB 40000:NEXT:SYSTEM
  919. 13580 IF LPRT THEN LPRINT "+++ Modem status is: ";HEX$(R1);" and line status is: ";HEX$(INP(LSR));" Error";ERR;" in line ";ERL
  920. 13590 RETURN
  921. 13600 A$="Disk full -- restoring USERS file.":GOSUB 1400:CLOSE 1,#2:KILL USERS$:NAME USERS.BAK$ AS USERS$:GOSUB 9400:RETURN
  922. 13610 A$="Disk full -- restoring MESSAGES file.":GOSUB 1400:CLOSE 1,#2:KILL MESSAGES$
  923. 13620 NAME MESSAGES.BAK$ AS MESSAGES$:GOSUB 135:RETURN
  924. 13630 A$="The SYSOP left the drive door open by mistake.":GOSUB 1400
  925. 13640 A$="The File Menu is not available today.":GOSUB 1400:RETURN
  926. 13650 CLS:LOCATE ,,0
  927. 13660 PRINT "Not enough memory to initialize RBBS-PC":GOTO 13570
  928. 13670 FOR JJ=1 TO 500:NEXT:RETURN
  929. 14000 'Return trap for F5 - force on-line
  930. 14010 RETURN 320
  931. 14500 PRINT #3,"ATQ1E0S0=0C0H1M0":GOSUB 40000:CLOSE 3:RETURN
  932. 15000 'Hold system open for SYSOP next ------------
  933. 15010 IF SYSOPNEXT THEN SYSOPNEXT=0:PRINT "Next caller gets system.":ELSE SYSOPNEXT=-1:PRINT "SYSOP gets system next."
  934. 15020 RETURN
  935. 20000 'File subsystem ------------------------------
  936. 20010 GOSUB 1400:A$="Entering File Subsystem...":GOSUB 1400
  937. 20015 IF LOCAL GOTO 20020 ELSE GOSUB 1400:GOSUB 41000:A$="Time remaining = "+TR$+" min.":GOSUB 1400 'CPC01
  938. 20020 IF XPR THEN 20030 ELSE GOSUB 50200 'CPC01
  939. 20030 GOSUB 1400:A$="File Function <G,H,L,D,U,M,?>" 'CPC01
  940. 20040 CR=1:GOSUB 1500:IF Q=0 THEN 20015 'CPC01
  941. 20050 Z$=B$(1):GOSUB 5000:FF=INSTR("LDUMGH?",Z$)
  942. 20060 IF FF=0 THEN A$=FIRST$+" I don't understand "+B$(1)+".":GOSUB 1400:GOTO 20015 'CPC09
  943. 20070 ON FF GOSUB 20150,20180,20400,20090,20100,20110,20130
  944. 20080 GOTO 20015
  945. 20090 RETURN 20095
  946. 20095 RETURN 1200
  947. 20100 RETURN 10560
  948. 20110 'Help subdirectory ---------------------------
  949. 20120 FILE$=HELP05$:GOSUB 6000:RETURN
  950. 20130 '? subdirectory ------------------------------
  951. 20140 FILE$=HELP06$:GOSUB 6000:RETURN
  952. 20150 'List option ---------------------------------
  953. 20155 IF INSTR(B$,";")>0 THEN STARTD=VAL(RIGHT$(B$,1)) ELSE STARTD=1 'CPC08
  954. 20160 A$="Files available for downloading..":CR=1:GOSUB 1400 'CPC01
  955. 20165 FOR X=STARTD TO LEN(FDEV$)-1:FILE$=MID$(FDEV$,X,1)+":"+DIR$:GOSUB 6000
  956. 20170 A$="End directory #"+STR$(X):IF X<LEN(FDEV$)-1 THEN A$=A$+". List more":GOSUB 1500:IF NO THEN RETURN
  957. 20175 NEXT:GOSUB 1400:RETURN
  958. 20180 'Download a file function --------------------------------
  959. 20190 IF Q>1 THEN B=2:GOTO 20202
  960. 20200 A$="Enter full filename to download":GOSUB 1500:B=1:IF Q=0 THEN RETURN
  961. 20202 A=1:IF Q>B THEN A=VAL(B$(B+1)):IF A<1 THEN A=1
  962. 20205 FOR X=A TO LEN(FDEV$)-1
  963. 20210 Z$=B$(B):GOSUB 5000:IF Z$=CONFIG$ GOTO 20231
  964. 20215 FILE$=MID$(FDEV$,X,1)+":"+B$(B)
  965. 20220 OK=0:NAME FILE$ AS FILE$
  966. 20225 IF OK THEN 20235 'CPC04
  967. 20230 NEXT 'CPC08
  968. 20231 A$="File <"+B$(B)+"> was not found. Type L for directory.":CR=2:GOSUB 1400 'CPC08
  969. 20232 IF LPRT THEN LPRINT "     File "+B$(B)+" was not found." 'CPC08
  970. 20233 GOTO 20020 'CPC08
  971. 20235 EXT$=RIGHT$(FILE$,4):IF EXT$=".EXE" OR EXT$=".exe" OR EXT$=".COM" OR EXT$=".com" THEN GOSUB 1400:A$="This is a binary file and requires XMODEM transfer...":GOSUB 1400
  972. 20236 Z$=FILE$:GOSUB 5000
  973. 20237 IF (Z$=MESSAGES$ OR Z$=MESSAGES.BAK$ OR Z$=COMMENTS$ OR Z$=USERS$ OR Z$=USERS$+".BAK" OR Z$=CALLERS$) GOTO 20231
  974. 20240 A$="Download type <X>modem, <A>scii, <Q>uit":CR=1:GOSUB 1500
  975. 20250 IF Q=0 THEN 20240 ELSE Z$=B$(1):FT$=Z$:GOSUB 5000
  976. 20260 FF=INSTR("XAQ",Z$):IF FF=0 THEN 20240
  977. 20270 ON FF GOTO 20290,20340,20280:'STOP 'CPC01
  978. 20280 RETURN
  979. 20290 'Download using XMODEM --------------------------------------
  980. 20300 OPEN "R",2,FILE$,128:GOSUB 20750
  981. 20305 IF NOT BIT.8 THEN GOSUB 1400:A$="Switching to N,8,1 for binary transfer. You do the same.":GOSUB 1400:CR=2:GOSUB 40000 'CPC10
  982. 20310 A$="Ready to send. Enter <Ctrl-X> to abort transfer...":GOSUB 1400:GOSUB 40000 'CPC10
  983. 20320 GOSUB 21300
  984. 20330 CLOSE 2
  985. 20335 C=2:A$="":GOSUB 1400:Y$=" downloaded ":GOSUB 50600:RETURN 'CPC05
  986. 20340 'Download using ASCII -------------------------------------------
  987. 20350 CLOSE 2:OPEN "I",#2,FILE$:GOSUB 20750
  988. 20360 A$="Transfer can be suspended with <CTL-S>, aborted with <CTL-X>.":CR=2:GOSUB 1400 'CPC01
  989. 20370 A$="Ready to send. Open download file then enter <C/R> to start":CR=1:GOSUB 1500 'CPC06
  990. 20380 ABT$=CAN$:STI=-1:GOSUB 6030:ABT$=CHR$(11):CR=2:IF RET THEN A$="<*>Download aborted<*>":GOTO 20390 'CPC09
  991. 20381 A$=CHR$(26):GOSUB 1400 'CPC01
  992. 20382 IF NOT LOCAL THEN FOR II=1 TO 5:PRINT #3,BELL$:GOSUB 40000:NEXT II
  993. 20383 A$="<*>End of file<*>" 'CPC01
  994. 20385 GOSUB 1400:Y$=" downloaded ":GOSUB 50600 'CPC05
  995. 20390 RETURN 'CPC03
  996. 20400 'Upload file functions -----------------------------------------
  997. 20410 IF Q=2 THEN B$(1)=B$(2):GOTO 20430
  998. 20420 CR=1:A$="Enter full name of file to be uploaded":GOSUB 1500:IF Q=0 THEN RETURN
  999. 20430 Z$=B$(1):GOSUB 5000 'CPC08
  1000. 20435 FOR X=1 TO LEN(FDEV$) 'CPC08
  1001. 20437 FILE$=MID$(FDEV$,X,1)+":"+Z$
  1002. 20440 OK=0:NAME FILE$ AS FILE$
  1003. 20450 IF NOT OK THEN 20460 'CPC08
  1004. 20455 NEXT X 'CPC08
  1005. 20460 IF NOT OK AND SYSOP THEN A$="File exists, overwrite or supersede":GOSUB 1500:IF YES THEN OK=-1
  1006. 20465 IF OK THEN FILE$=RIGHT$(FDEV$,1)+":"+Z$:OPEN "R",2,FILE$,128 'CPC08
  1007. 20470 IF NOT OK THEN CLOSE 2:A$="File <"+Z$+"> already exists. You must use a unique name.":CR=2:GOSUB 1400:GOTO 20420 'CPC01
  1008. 20475 Z$=LEFT$(FILE$,2)+DIR$:CR=2:GOSUB 1400:GOSUB 52000:A$="Upload disk has"+ACUM$:CR=2:GOSUB 1400 'CPC04
  1009. 20480 A$="Upload type <X>modem, <A>scii, <Q>uit":CR=1:GOSUB 1500
  1010. 20490 IF Q=0 THEN 20480 ELSE Z$=B$(1):FT$=Z$:GOSUB 5000
  1011. 20500 FF=INSTR("XAQ",Z$):IF FF=0 THEN 20480
  1012. 20510 ON FF GOTO 20530,20560,20740:STOP
  1013. 20520 '
  1014. 20530 'Upload using XMODEM -----------------------------------------
  1015. 20535 IF NOT BIT.8 THEN GOSUB 1400:A$="Switching to N,8,1 for binary transfer. You do the same, then start XMODEM.":CR=2:GOSUB 1400 'CPC01
  1016. 20540 A$="Ready to receive. Enter <Ctrl-X> to abort transfer...":GOSUB 1400:GOSUB 50500 'CPC06
  1017. 20550 OK=-1:GOSUB 20860:X#=0:IF OK THEN 20700 ELSE 20730
  1018. 20560 'Upload using ASCII ----------------------------------------
  1019. 20570 A$="Terminate the transfer with a <CTL-K>.":CR=2:GOSUB 1400 'CPC01
  1020. 20580 A$="Ready to receive file......":GOSUB 1400:OK=0:X=FALSE
  1021. 20585 CLOSE 2:OPEN "O",2,FILE$:PRINT "<Esc> from SYSOP will abort."
  1022. 20600 WHILE NOT EOF(3)
  1023. 20605 GOSUB 42000 'CPC01
  1024. 20607 IF LOF(3)<128 THEN PRINT#3,XOFF$;:X=TRUE
  1025. 20610 X$= INPUT$(LOC(3),3):IF INSTR(X$,ABT$) THEN 20650
  1026. 20620 OK=-1:PRINT #2,X$;
  1027. 20621 IF NOT OK THEN 20670
  1028. 20630 WEND:GOSUB 42000:IF X THEN X=FALSE:PRINT #3,XON$;
  1029. 20640 IF INKEY$=ESC$ THEN 20745 ELSE 20600
  1030. 20650 X=INSTR(X$,ABT$):IF X<>1 THEN PRINT #2,LEFT$(X$,X-1) ELSE IF NOT OK THEN 20730
  1031. 20660 A$="File upload complete.":GOSUB 1400:X#=128:GOTO 20700
  1032. 20670 A$=XOFF$+"System error, upload aborted, enter <CTL-K> to continue"
  1033. 20675 GOSUB 1400:FOR X=1 TO 2000:NEXT:PRINT #3,XON$;
  1034. 20680 WHILE NOT EOF(3):X$=INPUT$(LOC(3),3):IF INSTR(X$,CHR$(11)) THEN 20730
  1035. 20685 GOSUB 42000 'CPC01
  1036. 20690 WEND:GOTO 20680
  1037. 20700 X#=LOC(2)*128+X#:CLOSE 2:OPEN "A",2,LEFT$(FILE$,2)+DIR$:FILE$=MID$(FILE$,3)
  1038. 20710 A$="Enter a 40 character description of "+FILE$+"(begin with a / if for SYSOP only).":GOSUB 1400
  1039. 20715 A$=" |----+---1+0---+---2+0---+---3+0---+---4+0":GOSUB 1400:GOSUB 1500:IF LEN(B$(1))>40 THEN 20710
  1040. 20720 IF LEFT$(B$(1),1)="/" THEN 20725 ELSE PRINT#2,USING "\          \#######,  & - &";FILE$;X#;DATE$;B$(1)
  1041. 20725 CLOSE 2:Y$=" >> uploaded << ":GOSUB 50600:RETURN
  1042. 20730 A$="File upload abort. Partial file deleted from disk.":GOSUB 1400 'CPC01
  1043. 20740 CLOSE 2:KILL FILE$:RETURN
  1044. 20745 A$=XOFF$+"File upload aborted by SYSOP, stop transmission then enter <CTL-K> to continue":GOTO 20675
  1045. 20750 ' Print transfer time information ----------------------------
  1046. 20760 CNT#=FIX(LOF(2)/128):X#=LOF(2)/128:IF CNT#<>X# THEN X#=X#+1 'CPC08
  1047. 20770 GOSUB 1400:A$="File size is"+STR$(INT(X#))+" blocks.":GOSUB 1400 'CPC01
  1048. 20780 IF BPS=&H100 THEN X#=X#*139/45 ELSE IF BPS=-1 THEN X#=X#*139/120 ELSE X#=X#*139/30 'CPC03
  1049. 20790 A$="Transfer time:"+STR$(INT(X#/60))+" minutes,"+STR$(X# MOD 60)+" seconds.":GOSUB 1400:GOSUB 50500 'CPC01
  1050. 20800 GOSUB 41000: IF (INT(X#/60)+1)>INT(TR!/60) THEN A$="Sorry, not enough time left to download.":GOSUB 1400:GOSUB 20015 ELSE RETURN
  1051. 20810 'Get Character ----------------------------------------
  1052. 20820 GOSUB 42000:Y$="" 'CPC03
  1053. 20830 FOR XA=1 TO 4200 'CPC10
  1054. 20840 IF NOT EOF(3) THEN Y$=INPUT$(LOC(3),3):RETURN
  1055. 20850 NEXT XA:Y$="":RETURN
  1056. 20860 'Receive With Xmodem Protocol -----------------------------------
  1057. 20870 IF PRT THEN PRINT:PRINT ">>> SYSOP, enter <Esc> to cause early termination. <<<" 'CPC08
  1058. 20875 GOSUB 40000 'CPC06
  1059. 20881 IF NOT BIT.8 THEN OUT LCR,3:GOSUB 21280
  1060. 20900 X$="":SEC=1:FIELD 2,128 AS Z$
  1061. 20910 PRINT #3,NAK$;
  1062. 20920 FOR XB=1 TO 10:Y$=INKEY$:IF Y$=ESC$ THEN 21270 ELSE GOSUB 20810
  1063. 20930 IF LEFT$(Y$,1)=SOH$ THEN 21020
  1064. 20940 IF LEFT$(Y$,1)=EOT$ THEN 21220
  1065. 20950 IF LEFT$(Y$,1)=CAN$ THEN 21230
  1066. 20960 IF Y$<>"" THEN GOSUB 21280:GOTO 20920
  1067. 20970 NEXT XB
  1068. 20980 PRINT #3,NAK$;:IF PRT THEN PRINT "Timeout" 'CPC07
  1069. 20990 GOTO 20920 'CPC06
  1070. 21000 GOSUB 20810' Get Char
  1071. 21010 IF Y$="" THEN PRINT "Timeout":GOTO 21040
  1072. 21020 X$=X$+Y$
  1073. 21030 IF LEN(X$)<132 THEN 21000
  1074. 21040 IF LEN(X$)=132 THEN 21090
  1075. 21050 IF LEN(X$)>132 THEN 21180
  1076. 21060 IF X$=EOT$ THEN 21220
  1077. 21070 IF X$=CAN$ THEN 21230
  1078. 21080 GOTO 21170
  1079. 21090 IF SEC<>ASC(MID$(X$,2,1)) THEN 21200
  1080. 21100 IF (SEC XOR 255)<>ASC(MID$(X$,3,1)) THEN 21210
  1081. 21110 CK=0:FOR I=1 TO 128:CK=CK+ASC(MID$(X$,I+3,1)):NEXT:CK=(CK AND 255)
  1082. 21112 IF CK<>ASC(MID$(X$,132,1)) THEN 21190
  1083. 21120 PRINT #3,ACK$;
  1084. 21130 LSET Z$=MID$(X$,4):PUT 2
  1085. 21131 IF NOT OK THEN 21230
  1086. 21140 IF PRT THEN PRINT "Received #"SEC"("RIGHT$("0"+HEX$(SEC),2)")" 'CPC07
  1087. 21145 SEC=255 AND (SEC+1) 'CPC06
  1088. 21150 X$="":CK=0:GOTO 20920
  1089. 21160 IF PRT THEN PRINT SEC"("RIGHT$("0"+HEX$(SEC),2)")" 'CPC07
  1090. 21165 PRINT #3,NAK$;:GOTO 21150
  1091. 21170 IF PRT THEN PRINT "Short Block in #";
  1092. 21175 GOTO 21160
  1093. 21180 IF PRT THEN PRINT "Long Block in #";
  1094. 21185 GOTO 21160
  1095. 21190 IF PRT THEN PRINT "Checksum Error in #";
  1096. 21195 GOTO 21160
  1097. 21200 IF PRT THEN PRINT "Block # Error in #";
  1098. 21205 GOTO 21160
  1099. 21210 IF PRT THEN PRINT "Complement Error in #";
  1100. 21215 GOTO 21160
  1101. 21220 IF PRT THEN PRINT "File Closed."
  1102. 21225 PRINT #3,ACK$;:GOTO 21250
  1103. 21230 IF PRT THEN PRINT "Transfer Aborted."
  1104. 21240 OK=FALSE:PRINT #3,CAN$;CAN$;' abort end
  1105. 21250 ' end
  1106. 21260 IF NOT BIT.8 THEN GOSUB 21280:A$="Enter C/R after switching to E,7,1":GOSUB 1400:GOSUB 40000:OUT LCR,26:GOSUB 1500
  1107. 21265 RETURN 'CPC01
  1108. 21270 IF PRT THEN PRINT "Transfer aborted by <Esc> keyin"
  1109. 21275 GOSUB 21280:GOTO 21240
  1110. 21280 'Purge Buffer -----------------------------------
  1111. 21290 WHILE NOT EOF(3):DUMMY$=INPUT$(LOC(3),3):WEND:RETURN 'CPC01
  1112. 21300 'Send with Xmodem Protocol ---------------------------------------
  1113. 21310 IF PRT THEN PRINT:PRINT ">>> SYSOP, enter <Esc> to cause early termination. <<<" 'CPC08
  1114. 21320 IF NOT BIT.8 THEN GOSUB 40000:OUT LCR,3
  1115. 21330 SEC=0:GOSUB 21280 'Purge Buffer
  1116. 21340 FIELD #2,128 AS X$
  1117. 21350 WHILE NOT EOF(3) 'Wait for NAK
  1118. 21355 'CPC03
  1119. 21360 Y$=INPUT$(1,3)
  1120. 21370 IF Y$=CAN$ THEN 21560
  1121. 21380 IF Y$=NAK$ THEN 21480
  1122. 21390 WEND:GOSUB 42000:Y$=INKEY$:IF Y$=ESC$ THEN 21540 ELSE 21350 'CPC03
  1123. 21400 '
  1124. 21410 WHILE NOT EOF(3) 'Wait for ACK
  1125. 21415 'CPC03
  1126. 21420 Y$=INPUT$(1,3)
  1127. 21430 IF Y$=ACK$ THEN 21480
  1128. 21440 IF Y$<>NAK$ THEN 21450:IF PRT THEN PRINT "Re";
  1129. 21445 GOTO 21510
  1130. 21450 IF Y$=CAN$ THEN 21560
  1131. 21460 WEND:GOSUB 42000:Y$=INKEY$:IF Y$=ESC$ THEN 21540 ELSE 21410 'CPC03
  1132. 21470 '
  1133. 21480 IF LOC(2)<LOF(2)/128 THEN 21490 'CPC07
  1134. 21482 IF PRT THEN PRINT "End of file" 'CPC07
  1135. 21485 GOTO 21530 'CPC07
  1136. 21490 GET 2:SEC=255 AND (SEC+1)
  1137. 21500 A$=SOH$+CHR$(SEC)+CHR$(SEC XOR 255)+X$
  1138. 21501 CK=0:FOR I=1 TO LEN(A$):CK=CK+ASC(MID$(A$,I,1)):NEXT:CK=(CK AND 255)
  1139. 21502 IF CK>256 THEN CK=CK-256:GOTO 21502
  1140. 21503 A$=A$+CHR$(CK)
  1141. 21510 IF PRT THEN PRINT "Send #"SEC"("RIGHT$("0"+HEX$(SEC),2)")"
  1142. 21520 PRINT #3,A$;:GOSUB 21280:GOTO 21410
  1143. 21530 PRINT #3,EOT$;:FOR X=1 TO 100:GOSUB 20810:IF Y$=ACK$ THEN 21570 ELSE Y$=INKEY$:IF Y$<>ESC$ THEN NEXT:GOSUB 21280:GOTO 21530
  1144. 21540 IF PRT THEN PRINT "Transfer aborted by <Esc> keyin"
  1145. 21545 PRINT #3,CAN$;CAN$;:GOTO 21570
  1146. 21550 IF PRT THEN PRINT "Transmission Ended."
  1147. 21555 PRINT #3,EOT$;:GOTO 21570
  1148. 21560 IF PRT THEN PRINT "Transmission Aborted by Receiver"
  1149. 21570 ' end
  1150. 21580 IF NOT BIT.8 THEN GOSUB 21280:A$="Enter C/R after switching to E,7,1":GOSUB 1400:GOSUB 40000:OUT LCR,26:GOSUB 1500
  1151. 21585 RETURN 'CPC01
  1152. 21590 GOTO 21550
  1153. 30000 'CPC01 Force Chat Mode    [ KEY 10 ] ---------------
  1154. 30010 'CPC01 B$=SYSOP'S CHARACTER, C$=USER'S CHARACTER
  1155. 30020 A$=CHR$(12)+"SYSOP is active....You are now in CHAT mode...":CR=2:GOSUB 1400 'CPC01
  1156. 30025 GOSUB 50500:A$="Hello, this is "+NFIR$+" "+NLAS$+". Sorry to break in but....":CR=2:GOSUB 1400
  1157. 30030 GOSUB 4770:RETURN 'CPC01
  1158. 31000 'CPC01 Return to System    [ KEY 1 ] ---------------
  1159. 31010 ON ERROR GOTO 0:CLS:SYSTEM 'CPC01
  1160. 32000 'CPC01 Exit into BASIC     [ KEY 2 ]
  1161. 32010 CLS:KEY 1,"LIST ":KEY 2,"RUN"+CHR$(13):KEY 3,"LOAD"+STRING$(1,34):KEY 4,"SAVE"+STRING$(1,34) 'CPC01 Set first four keys
  1162. 32020 KEY ON:CLEAR:END:RETURN 'CPC01
  1163. 33000 'CPC01 Toggle Line Printer [ KEY 3 ] ------------------
  1164. 33010 LPRT=NOT LPRT:IF (PRT AND LPRT) THEN PRINT "Line Printer ON." ELSE IF (PRT AND NOT LPRT) THEN PRINT "Line Printer OFF."
  1165. 33020 RETURN 'CPC01
  1166. 33040 'Toggle Page Bell despite preset times from line 182   [ KEY 4 ]  CPC03 ------------------
  1167. 33050 ANNOY=NOT ANNOY:IF (PRT AND ANNOY) THEN PRINT "Page bell is ON." ELSE IF (PRT AND NOT ANNOY) THEN PRINT "Page bell is temporarily OFF. Will reset to ON with next caller."
  1168. 33060 RETURN
  1169. 39000 'CPC01 Toggle Snoop on     [ KEY 9 ] -------------------------
  1170. 39010 IF PRT THEN PRT=FALSE:LOCATE ,,0:CLS:RETURN 'CPC01
  1171. 39020 LOCATE 25,1,0:PRINT SPACE$(79-(LEN(NAM$)+10));NAM$"  "TI$;:IF NAM$="" THEN LOCATE 25,45,0:PRINT"No one has been on since"; 'CPC01
  1172. 39030 PRT=TRUE:LOCATE 25,1,1:PRINT"SNOOP ON...  FREE SPACE=" FRE("A");:LOCATE 23,1,1 'CPC08
  1173. 39040 LOCATE 24,35:PRINT"--------------------------------------------" 'CPC01
  1174. 39050 LOCATE 24,35:PRINT"| [F1] - SYSTEM       | [F2] - BASICA      |" 'CPC01
  1175. 39060 LOCATE 24,35:PRINT"| [F3] - PRINT TOGGLE | [F4] - PAGE TOGGLE |" 'CPC03
  1176. 39070 LOCATE 24,35:PRINT"| [F5] - GO ON-LINE   | [F6] -              |"
  1177. 39080 LOCATE 24,35:PRINT"| [F7] - SYSOP ON NEXT| [F8] -             |" '
  1178. 39090 LOCATE 24,35:PRINT"| [F9] - SNOOP TOGGLE | [F10]- FORCE CHAT  |" 'CPC01
  1179. 39100 LOCATE 24,35:PRINT"--------------------------------------------" 'CPC01
  1180. 39110 RETURN 'CPC01
  1181. 40000 '3 sec time delay for display ---------------------
  1182. 40010 FOR JJ=1 TO 40:SOUND 32767,1:NEXT JJ 'CPC01
  1183. 40020 RETURN 'CPC01
  1184. 41000 'CPC01 Time remaining ----------------------
  1185. 41005 IF FNTI!>TI! THEN TIME.ON.SYS!=FNTI!-TI! ELSE TIME.ON.SYS!=FNTI!+864000!
  1186. 41010 TR!=TIME.MAX!-TIME.ON.SYS!:IF TR!<0 THEN 10560 'CPC03
  1187. 41020 TR$=STR$(INT(TR!/60)):RETURN 'CPC01
  1188. 42000 'CPC01 Check for COMM port carrier detect ----------------------
  1189. 42005 IF LOCAL THEN RETURN:IF CTI!>TI! THEN CTI!=TI!+(10*60)
  1190. 42010 IF INP(MSR)<128 THEN 13540
  1191. 42020 RETURN 'CPC01
  1192. 50000 'non-recoverable error or ERROR.MAX exceeded ------------------
  1193. 50005 A$="A Fatal error has occurred...System going down now":GOSUB 1400:RUN 90 'CPC01
  1194. 50010 CLOSE : RUN 90 'CPC01
  1195. 50020 ' CPC02
  1196. 50100 'Main menu -------------------------------------------------'CPC01
  1197. 50105 A$=" ":GOSUB 1400 'CPC01
  1198. 50110 A$="      ===================== RBBS-PC MAIN MENU ====================":GOSUB 1400 'CPC01
  1199. 50120 A$=" ":GOSUB 1400 'CPC01
  1200. 50130 A$="      B)ulletins     C)omment      E)nter message   F)iles menu":GOSUB 1400 'CPC01
  1201. 50140 A$="      G)oodbye       H)elp         K)ill a message  L)ine feeds":GOSUB 1400 'CPC01
  1202. 50150 A$="      M)sg margin    N)ew baud     O)perator        P)rompt sound":GOSUB 1400 'CPC01
  1203. 50160 A$="      PL)age length  PW)assword    Q)uick scan      R)ead messages":GOSUB 1400 'CPC01
  1204. 50170 A$="      S)can msgs     T)ime         U)serslog        W)elcome":GOSUB 1400 'CPC02
  1205. 50175 A$="      X)pert on/off  #)statistics  ?)Functions      !)Personal mail":GOSUB 1400 'CPC06
  1206. 50176 A$="      $)Nulls":GOSUB 1400 
  1207. 50180 RETURN 'CPC01
  1208. 50190 'CPC01
  1209. 50200 'File menu ------------------------------------------- 'CPC01
  1210. 50210 A$=" ":GOSUB 1400 'CPC01
  1211. 50220 A$="      ===================== RBBS-PC FILE MENU ====================":GOSUB 1400 'CPC01
  1212. 50230 A$=" ":GOSUB 1400 'CPC01
  1213. 50240 A$="              G)oodbye      H)elp        D)ownload a file":GOSUB 1400 'CPC01
  1214. 50250 A$="              L)ist files   M)ain menu   U)pload a file":GOSUB 1400 'CPC01
  1215. 50260 '
  1216. 50270 A$="              ?) Xfer Info":GOSUB 1400 'CPC01
  1217. 50280 RETURN 'CPC01
  1218. 50300 '
  1219. 50305 '
  1220. 50310 '
  1221. 50320 '
  1222. 50400 'Message menu ---------------------------------------- 'CPC01
  1223. 50410 A$=" ":GOSUB 1400 'CPC01
  1224. 50440 A$="<A>bort, <C>ontinue, <D>elete, <E>dit, <I>nsert, <L>ist, <M>argin, <S>ave":GOSUB 1400 'CPC01
  1225. 50480 RETURN 'CPC01
  1226. 50500 'One sec time delay CPC01 ----------------------------
  1227. 50510 FOR JJ=1 TO 18:SOUND 32700,1:NEXT:RETURN 'CPC01
  1228. 50600 ' record the file downloaded/upload ----------------------------------
  1229. 50610 GOSUB 482:Y$="     "+FILE$+Y$+"at "+TIM$+" using "+FT$ 'CPC08
  1230. 50612 CLOSE 2:OPEN "A",2,CALLERS$:PRINT #2,Y$:CLOSE 2 'CPC05
  1231. 50615 IF LPRT THEN LPRINT Y$ 'CPC05
  1232. 50620 RETURN
  1233. 52000 'Get info on free space from screen---------------------------CPC04
  1234. 52010 ACUM$="":CLS:FILES Z$:CC=CSRLIN-2 'CPC04
  1235. 52020 FOR RICH=1 TO 25:T=SCREEN(CC,RICH):IF T>122 THEN 52023
  1236. 52022 ACUM$=ACUM$+CHR$(T)
  1237. 52023 NEXT RICH:GOSUB 950:LOCATE CC+2,1:IF NOT PRT THEN CLS
  1238. 52024 IF MID$(ACUM$,9,10)="Bytes free" THEN RETURN
  1239. 52030 ACUM$=" 2010 -- free space unavailable"
  1240. 52035 IF NOT COMPILED THEN RETURN
  1241. 52040 DR=INSTR("ABCDEF",LEFT$(Z$,1))
  1242. 52050 IF DR=0 THEN GOTO 52100
  1243. 52060 CALL UTSPACE(DR,AVAIL,TOTAL,BYTES,SECTORS)
  1244. 52070 DR!=DR:AVAIL!=AVAIL:BYTES!=BYTES:SECTORS!=SECTORS
  1245. 52080 TOTAL.BYTES!=AVAIL!*BYTES!*SECTORS!
  1246. 52090 ACUM$ = STR$(TOTAL.BYTES!)+" Bytes free"
  1247. 52100 RETURN
  1248. 63000 'CPC01 - *** END OF PROGRAM ***
  1249.